unit JFSendMail;
interface
uses
Vcl.ComCtrls, System.SysUtils, System.Classes, System.IOUtils, IdSmtp, IdMessage, IdAttachmentFile, IdText, IdExplicitTLSClientServerBase, IdSSLOpenSSL, IdBaseComponent, IdIOHandler,
IdIOHandlerSocket, IdIOHandlerStack, IdSSL;
type
TLoginType = (ltNone, ltLogin);
TMailPriority = (pHighest, pHigh, pNormal, pLow, pLowest);
TJFSendMail =
class
private
fLibeay32, fSSLeay32:
string;
fSmtp: TIdSMTP;
fIdSSLIOHandler: TIdSSLIOHandlerSocketOpenSSL;
fMsg: TIdMessage;
fAttachmentList: TStringList;
fiEMailSize: Integer;
bUseSSL: Boolean;
iTLSMode: Integer;
procedure SetLibeay32(
const aValue:
string);
procedure SetSSLeay32(
const aValue:
string);
procedure SetHost(
const aValue:
string);
procedure SetPort(
const aValue: Word);
procedure SetUserName(
const aValue:
string);
procedure SetPwd(
const aValue:
string);
procedure SetLoginType(
const aValue: TLoginType);
procedure SetMailAgent(
const aValue:
string);
procedure SetReceiver(
const aValue:
string);
procedure SetSender(
const aValue:
string);
procedure SetSubject(
const aValue:
string);
procedure SetPriority(
const aValue: TMailPriority);
procedure SetReturnReciept(
const aValue: Boolean);
procedure SetBody(aValue: TStrings);
procedure SetUseSSL(
const aValue: Boolean);
procedure SetTLSMode(
const aValue: Integer);
function getLibeay32:
string;
function getSSLeay32:
string;
function getHost:
string;
function getPort: Word;
function getUserName:
string;
function getPwd:
string;
function getLoginType: TLoginType;
function getMailAgent:
string;
function getReceiver:
string;
function getSender:
string;
function getSubject:
string;
function getPriority: TMailPriority;
function getReturnReciept: Boolean;
function getBody: TStrings;
function getUseSSL: Boolean;
function getTLSMode: Integer;
procedure setEmailSize(iEMailSize: Integer);
protected
public
constructor Create;
destructor Destroy;
override;
property Libeay32:
string read getLibeay32
write SetLibeay32;
property SSLeay32:
string read getSSLeay32
write SetSSLeay32;
property Host:
string read getHost
write SetHost;
property Port: Word
read getPort
write SetPort;
property Username:
string read getUserName
write SetUserName;
property Password:
string read getPwd
write SetPwd;
property LoginType: TLoginType
read getLoginType
write SetLoginType;
property MailAgent:
string read getMailAgent
write SetMailAgent;
property Receiver:
string read getReceiver
write SetReceiver;
property Sender:
string read getSender
write SetSender;
property Subject:
string read getSubject
write SetSubject;
property Priority: TMailPriority
read getPriority
write SetPriority;
property ReturnReciept: Boolean
read getReturnReciept
write SetReturnReciept;
property Body: TStrings
read getBody
write SetBody;
property Attachments: TStringList
read fAttachmentList;
property UseSSL: Boolean
read getUseSSL
write SetUseSSL;
property TLSMode: Integer
read getTLSMode
write SetTLSMode;
function SendMail: Boolean;
end;
implementation
function _MIMEConvert(s:
string):
string;
var
i: Integer;
begin
Result := '
';
for i := 1
to Length(s)
do
begin
if s[i] = '
€'
then
begin
Result := Result + '
?=ISO-8859-15?Q?=A4?='
end
else if Ord(s[i]) > $99
then
Result := Result + '
=?ISO-8859-1?Q?=' + Format('
%x', [Ord(s[i])]) + '
?='
else
Result := Result + s[i];
end;
end;
constructor TJFSendMail.Create;
begin
fSmtp := TIdSMTP.Create(
nil);
fIdSSLIOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(
nil);
fMsg := TIdMessage.Create(
nil);
fAttachmentList := TStringList.Create;
end;
destructor TJFSendMail.Destroy;
begin
FreeAndNil(fSmtp);
FreeAndNil(fIdSSLIOHandler);
FreeAndNil(fMsg);
FreeAndNil(fAttachmentList);
inherited;
end;
function TJFSendMail.getLoginType: TLoginType;
begin
if fSmtp.AuthType = satNone
then
Result := ltNone
else
Result := ltLogin;
end;
function TJFSendMail.getHost:
string;
begin
Result := fSmtp.Host;
end;
function TJFSendMail.getPort: Word;
begin
Result := fSmtp.Port;
end;
function TJFSendMail.getPwd:
string;
begin
Result := fSmtp.Password;
end;
function TJFSendMail.getUserName:
string;
begin
Result := fSmtp.Username;
end;
procedure TJFSendMail.SetLoginType(
const aValue: TLoginType);
begin
if aValue = ltNone
then
fSmtp.AuthType := satNone
else
fSmtp.AuthType := satDefault;
end;
procedure TJFSendMail.SetHost(
const aValue:
string);
begin
if aValue <> fSmtp.Host
then
fSmtp.Host := aValue;
end;
procedure TJFSendMail.SetPort(
const aValue: Word);
begin
if aValue <> fSmtp.Port
then
fSmtp.Port := aValue;
end;
procedure TJFSendMail.SetPwd(
const aValue:
string);
begin
if aValue <> fSmtp.Password
then
fSmtp.Password := aValue;
end;
procedure TJFSendMail.SetUserName(
const aValue:
string);
begin
if aValue <> fSmtp.Username
then
fSmtp.Username := aValue;
end;
function TJFSendMail.getMailAgent:
string;
begin
Result := fSmtp.MailAgent;
end;
procedure TJFSendMail.SetMailAgent(
const aValue:
string);
begin
if aValue <> fSmtp.MailAgent
then
fSmtp.MailAgent := aValue;
end;
function TJFSendMail.getBody: TStrings;
begin
Result := fMsg.Body;
end;
function TJFSendMail.getUseSSL;
begin
Result := bUseSSL;
end;
function TJFSendMail.getTLSMode;
begin
Result := iTLSMode;
end;
function TJFSendMail.getPriority: TMailPriority;
var
iTmp: Byte;
begin
iTmp := Ord(fMsg.Priority);
Result := TMailPriority(iTmp);
end;
function TJFSendMail.getReceiver:
string;
begin
Result := fMsg.Recipients.EMailAddresses;
end;
function TJFSendMail.getReturnReciept: Boolean;
begin
Result := fMsg.ReceiptRecipient.Text <> '
';
end;
function TJFSendMail.getSender:
string;
begin
Result := fMsg.From.Text;
end;
function TJFSendMail.getSSLeay32:
string;
begin
Result := fSSLeay32;
end;
function TJFSendMail.getLibeay32:
string;
begin
Result := fLibeay32;
end;
function TJFSendMail.getSubject:
string;
begin
Result := fMsg.Subject;
end;
procedure TJFSendMail.SetBody(aValue: TStrings);
begin
fMsg.Body.Assign(aValue);
end;
procedure TJFSendMail.SetUseSSL(
const aValue: Boolean);
begin
bUseSSL := aValue;
end;
procedure TJFSendMail.SetTLSMode(
const aValue: Integer);
begin
iTLSMode := aValue;
end;
procedure TJFSendMail.SetPriority(
const aValue: TMailPriority);
var
iTmp: Byte;
begin
iTmp := Ord(aValue);
fMsg.Priority := TIdMessagePriority(iTmp);
end;
procedure TJFSendMail.SetReceiver(
const aValue:
string);
begin
fMsg.Recipients.EMailAddresses := aValue;
end;
procedure TJFSendMail.SetReturnReciept(
const aValue: Boolean);
begin
if aValue
then
fMsg.ReceiptRecipient.Text := fMsg.From.Text
else
fMsg.ReceiptRecipient.Text := '
';
end;
procedure TJFSendMail.SetSender(
const aValue:
string);
begin
fMsg.From.Text := aValue;
end;
procedure TJFSendMail.SetSSLeay32(
const aValue:
string);
begin
fSSLeay32 := aValue;
end;
procedure TJFSendMail.SetLibeay32(
const aValue:
string);
begin
fLibeay32 := aValue;
end;
procedure TJFSendMail.SetSubject(
const aValue:
string);
begin
fMsg.Subject := aValue;
end;
procedure TJFSendMail.setEmailSize(iEMailSize: Integer);
begin
fiEMailSize := iEMailSize;
end;
function TJFSendMail.SendMail: Boolean;
var
i: Integer;
begin
Result := False;
try
fMsg.Subject := _MIMEConvert(fMsg.Subject);
if fAttachmentList.Count > 0
then
begin
for i := 0
to fAttachmentList.Count - 1
do
begin
if FileExists(fAttachmentList[i])
then
begin
TIdAttachmentFile.Create(fMsg.MessageParts, fAttachmentList[i]);
TIdText.Create(fMsg.MessageParts).ContentType := '
text/html';
TIdText.Create(fMsg.MessageParts).CharSet := '
ISO-8859-1';
if i = 0
then
TIdText.Create(fMsg.MessageParts).Body.Add(fMsg.Body.Text);
end;
end;
end
else
begin
fMsg.ContentType := '
text/html';
fMsg.CharSet := '
ISO-8859-1';
end;
setEmailSize(Length(fMsg.Body.Text));
fSmtp.ConnectTimeout := 10000;
if getUseSSL
and FileExists(fLibeay32)
and FileExists(fSSLeay32)
then
begin
fSmtp.IOHandler := fIdSSLIOHandler;
fSmtp.UseTLS := TIdUseTLS(getTLSMode);
{*
0 utNoTLSSupport
1 utUseImplicitTLS
2 utUseRequireTLS
3 utUseExplicitTLS
*}
end;
try
fSmtp.Connect;
if fSmtp.Connected
then
begin
try
fSmtp.Send(fMsg);
Result := True;
finally
fSmtp.Disconnect;
end;
end;
except
Result := False;
end;
except
Result := False;
end;
end;
end.