Hi, Compose the mail and store to database, once the mail is ready to be send, call the mail sender, see the code
unit MailsForm;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, uniGUITypes, uniGUIAbstractClasses, uniGUIClasses, uniGUIForm, StrUtils, IdCoderMIME, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdExplicitTLSClientServerBase, IdMessageClient, IdSMTPBase, IdSMTP, IdMessage, IdAttachment, IdAttachmentFile, IdText, DB, ADODB, uniGUIBaseClasses, uniButton;
type
TFormMails = class(TUniForm)
QryMain: TADOQuery;
QryMainEmailId: TAutoIncField;
QryMainFolder: TIntegerField;
QryMainTagIO: TStringField;
QryMainRefDate: TDateTimeField;
QryMainSize: TIntegerField;
QryMainFromEmail: TMemoField;
QryMainToEmail: TMemoField;
QryMainCCEmail: TMemoField;
QryMainBCCEmail: TMemoField;
QryMainSubject: TMemoField;
QryMainBody: TMemoField;
QryMainRawMsg: TBlobField;
QryMainIsSubmitted: TBooleanField;
QryMainIsSent: TBooleanField;
QryMainSentDate: TDateTimeField;
QryMainUsersId: TIntegerField;
QryMainIsReaded: TBooleanField;
QryMainMainId: TAutoIncField;
QryMainTndrId: TIntegerField;
QryDetailA: TADOQuery;
QryDetailAEmailDetId: TAutoIncField;
QryDetailAEmailId: TIntegerField;
QryDetailAAtchFileName: TStringField;
QryDetailAAtchFileData: TBlobField;
QryDetailAAtchSize: TIntegerField;
QryDetailAMainId: TIntegerField;
ButtonSendMail: TUniButton;
procedure ButtonSendMailClick(Sender: TObject);
private
procedure SendHtmlMail;
procedure ProcessHtml(var HBody: WideString; AtchList: TStringList);
procedure Decode2File(const base64: String; const FileName: string);
function MyBase64Decode(const EncodedText: string): TBytes;
{ Private declarations }
public
{ Public declarations }
end;
implementation
uses
uniGUIApplication, ServerModule, MainModule;
{$R *.dfm}
{ TUniForm1 }
procedure TFormMails.ButtonSendMailClick(Sender: TObject);
begin
if not (QryMain.State in [dsInsert,dsEdit]) then QryMain.Edit;
QryMainIsSubmitted.Value:=True;
QryMain.Post;
if (not QryMainIsSent.AsBoolean) and (QryMainIsSubmitted.AsBoolean) then
SendHtmlMail();
end;
procedure TFormMails.Decode2File(const base64, FileName: string);
var
stream: TFileStream;
bytes: TBytes;
begin
bytes := MyBase64Decode(base64);
stream := TFileStream.Create(FileName, fmCreate);
try
if bytes<>nil then
stream.Write(bytes[0], Length(Bytes));
finally
stream.Free;
end;
end;
function TFormMails.MyBase64Decode(const EncodedText: string): TBytes;
var
DecodedStm: TBytesStream;
Decoder: TIdDecoderMIME;
begin
Decoder := TIdDecoderMIME.Create(nil);
try
DecodedStm := TBytesStream.Create;
try
Decoder.DecodeBegin(DecodedStm);
Decoder.Decode(EncodedText);
Decoder.DecodeEnd;
Result := DecodedStm.Bytes;
SetLength(Result, DecodedStm.Size);
finally
DecodedStm.Free;
end;
finally
Decoder.Free;
end;
end;
procedure TFormMails.ProcessHtml(var HBody: WideString; AtchList: TStringList);
var
sHtm,sBase: WideString;
i,iCid,iPart,klen: integer;
sKey,TmpAtchfile: String;
bSkip:Boolean;
begin
AtchList.Clear;
sHtm := QryMainBody.AsString;
sKey := '<img src="data:';
klen := length(sKey);
bSkip:= False;
iCid := 0;
HBody:= '';
sBase:= '';
iPart:= 1;
for i:=1 to Length(sHtm) do begin
if iPart=1 then
HBody:=HBody +sHtm[i]
else if iPart=2 then begin
if not bSkip then sBase:=sBase +sHtm[i];
if (RightStr(sBase,7)= 'base64,') then sBase:='';
if (RightStr(sBase,6)= '" alt=') then begin
SetLength(sBase,length(sBase)-6);
bSkip:=True;
end;
end;
if (iPart=1) and (RightStr(HBody, klen)=sKey) then
iPart:=2
else if (iPart=2) and (sHtm[i]='>') then begin
iPart:=1;
bSkip:=False;
SetLength(HBody, length(HBody)-5);
HBody := HBody +'cid:ImgID' +InttoStr(iCid) +'">';
TmpAtchfile := UniServerModule.LocalCachePath +'Tmp'+InttoStr(iCid);
Decode2File(sBase, pchar(TmpAtchfile));
sBase:='';
AtchList.Add(TmpAtchfile);
iCid:=iCid+1;
end;
end;
end;
procedure TFormMails.SendHtmlMail;
var
i:Integer;
HtmPart, TxtPart: TIdText;
BmpPart: TIdAttachment;
Msg: TIdMessage;
IdSMTP: TIdSMTP;
AtchFile, sSql: String;
sHBody: WideString;
AtchList: TStringList;
begin
sHBody:='';
AtchList:= TStringList.Create;
ProcessHtml(sHBody, AtchList);
Msg := TIdMessage.Create(nil);
Msg.From.address := QryMainFromEmail.AsString;
Msg.Recipients.EMailAddresses := QryMainToEmail.AsString;
Msg.CCList.EMailAddresses := QryMainCCEmail.AsString;
Msg.BccList.EMailAddresses := QryMainBCCEmail.AsString;
Msg.Subject := QryMainSubject.AsString;
Msg.ContentType := 'multipart/alternative';
TxtPart := TIdText.Create(Msg.MessageParts);
TxtPart.ContentType := 'text/plain';
TxtPart := TIdText.Create(Msg.MessageParts);
TxtPart.ContentType := 'multipart/related; type="text/html"';
HtmPart := TIdText.Create(Msg.MessageParts, nil);
HtmPart.ContentType := 'text/html';
HtmPart.Body.Add('<html>');
HtmPart.Body.Add('<head>');
HtmPart.Body.Add('</head>');
HtmPart.Body.Add('<body>');
HtmPart.Body.Add(sHBody);
HtmPart.Body.Add('</body>');
HtmPart.Body.Add('</html>');
HtmPart.ParentPart := 1;
for i:=0 to AtchList.Count-1 do begin
BmpPart := TIdAttachmentFile.Create(Msg.MessageParts, pchar(AtchList[i]));
BmpPart.ContentType := 'image/jpeg';
BmpPart.ContentDisposition := 'inline';
BmpPart.ContentID := 'ImgID'+ IntToStr(i);
BmpPart.ParentPart := 1;
end;
Msg.ContentType := 'multipart/mixed';
QryDetailA.First;
while not QryDetailA.Eof do begin
AtchFile := UniServerModule.LocalCachePath +QryDetailAAtchFileName.AsString;
QryDetailAAtchFileData.SaveToFile(PChar(AtchFile));
TIdAttachmentFile.Create(Msg.MessageParts, AtchFile);
QryDetailA.Next;
end;
IdSMTP := TIdSMTP.Create(nil);
with UniMainModule do begin
idSMTP.Username := QryFirmSmtpUser.AsString;
idSMTP.Password := QryFirmSmtpPw.AsString;
idSMTP.Host := QryFirmSmtpHost.AsString;
idSMTP.Port := QryFirmSmtpPort.AsInteger;
end;
try
idSMTP.Connect();
try
idSMTP.Send(Msg);
sSql:= 'UPDATE Email SET Folder = 1, IsSent = 1, SentDate = GETDATE() WHERE (EmailId=0';
sSql:= sSql +QryMainMainId.AsString +')';
UniMainModule.Conn.Execute(Pchar(sSql));
ShowMessage('Message Sent');
except
on E: Exception do ShowMessage('Failed: ' + E.Message);
end;
finally
if IdSMTP.Connected then idSMTP.Disconnect();
Msg.Free;
IdSMTP.Free;
AtchList.Clear;
AtchList.Free;
end;
end;
end.
TestEMails.rar
TestRetriveMails.rar
