unit
SSLMails;
interface
uses
Windows, SysUtils, Classes,
IdMessage, IdPOP3, IdSMTP, IdSSLOpenSSL, IdExplicitTLSClientServerBase,
DllThreads, EClasses, VarRecs
;
type
{
$M
+}
TSSL_SMTP =
class
(TObject)
private
f_MSG: TIdMessage;
f_SMTP: TIdSMTP;
f_SSL: TIdSSLIOHandlerSocketOpenSSL;
f_Host:
String
;
f_Port:
Word
;
f_ConnectTimeout:
LongWord
;
f_Login:
String
;
f_Password:
String
;
f_FromAddress:
String
;
f_ToAddresses:
String
;
f_Subject:
String
;
f_Message:
String
;
f_LastError: Exception;
protected
procedure
SetHost (
const
aValue:
String
);
procedure
SetPort (
const
aValue:
Word
);
procedure
SetLogin (
const
aValue:
String
);
procedure
SetPassword (
const
aValue:
String
);
procedure
SetFromAddress (
const
aValue:
String
);
procedure
SetToAddresses (
const
aValue:
String
);
procedure
SetSubject (
const
aValue:
String
);
procedure
SetMessage (
const
aValue:
String
);
function
GetLastError :
String
;
procedure
SetConnectTimeout (
const
aValue:
LongWord
);
public
constructor
Create (anArgs:
array
of
const
); virtual;
destructor
Destroy; override;
class
function
Send (anArgs:
array
of
const
) :
Boolean
; overload;
function
Send :
Boolean
; overload;
property
Host:
String
read f_Host
write
SetHost;
property
Port:
Word
read f_Port
write
SetPort;
property
Login:
String
read f_Login
write
SetLogin;
property
Password:
String
read f_Password
write
SetPassword;
property
FromAddress:
String
read f_FromAddress
write
SetFromAddress;
property
ToAddresses:
String
read f_ToAddresses
write
SetToAddresses;
property
Subject:
String
read f_Subject
write
SetSubject;
property
Message:
String
read f_Message
write
SetMessage;
property
LastError:
String
read GetLastError;
property
ConnectTimeout:
LongWord
read f_ConnectTimeout
write
SetConnectTimeout;
end
;
{
$M
-}
implementation
constructor
TSSL_SMTP
.
Create (anArgs:
array
of
const
);
var
I :
Integer
;
begin
try
inherited
Create;
f_Host :=
''
;
if
( ( High (anArgs) >=
0
)
and
( ParamToStr (anArgs [
0
]) <>
'default'
) )
then
Host := ParamToStr (anArgs [
0
]);
f_Port :=
443
;
if
( ( High (anArgs) >=
1
)
and
( ParamToStr (anArgs [
1
]) <>
'default'
) )
then
Port := ParamToInt (anArgs [
1
]);
f_Login :=
''
;
if
( ( High (anArgs) >=
2
)
and
( ParamToStr (anArgs [
2
]) <>
'default'
) )
then
Login := ParamToStr (anArgs [
2
]);
f_Password :=
''
;
if
( ( High (anArgs) >=
3
)
and
( ParamToStr (anArgs [
3
]) <>
'default'
) )
then
Password := ParamToStr (anArgs [
3
]);
f_FromAddress :=
''
;
if
( (f_Host <>
''
)
and
(f_Login <>
''
) )
then
FromAddress := Format (
'%s@%s'
,[f_Login,f_Host]);
if
( ( High (anArgs) >=
4
)
and
( ParamToStr (anArgs [
4
]) <>
'default'
) )
then
FromAddress := ParamToStr (anArgs [
4
]);
f_ToAddresses :=
''
;
if
( ( High (anArgs) >=
5
)
and
( ParamToStr (anArgs [
5
]) <>
'default'
) )
then
ToAddresses := ParamToStr (anArgs [
5
]);
f_Subject :=
''
;
if
( ( High (anArgs) >=
6
)
and
( ParamToStr (anArgs [
6
]) <>
'default'
) )
then
Subject := ParamToStr (anArgs [
6
]);
f_Message :=
''
;
for
I :=
7
to
High (anArgs)
do
Message := Format (
'%s'
#
13
#
10
'%s'
, [ f_Message, ParamToStr (anArgs [i]) ]);
f_ConnectTimeout :=
3000
;
f_MSG :=
NIL
;
f_MSG := TIdMessage
.
Create;
if
(
not
Assigned (f_MSG) )
then
raise
Exception
.
Create (
'Ошибка создания структуры сообщения!'
);
with
f_MSG
do
begin
From
.
Address := f_FromAddress;
Recipients
.
EMailAddresses := ToAddresses;
Subject := UTF8Encode (f_Subject);
Date := now;
end
;
f_SMTP :=
NIL
;
f_SMTP := TIdSMTP
.
Create (
NIL
);
if
(
not
Assigned (f_SMTP) )
then
raise
Exception
.
Create (
'Ошибка создания SMTP-клиента!'
);
with
f_SMTP
do
begin
Host := f_Host;
Port := f_Port;
ConnectTimeout := f_ConnectTimeout;
UserName := f_Login;
Password := f_Password;
AuthType := atDefault;
end
;
f_SSL :=
NIL
;
f_SSL := TIdSSLIOHandlerSocketOpenSSL
.
Create (
NIL
);
if
(
not
Assigned (f_SSL) )
then
raise
Exception
.
Create (
'Ошибка создания SSL-сессии!'
);
with
f_SSL
do
begin
Host := f_Host;
Port := f_Port;
Destination := Format (
'%s:%d'
,[f_Host,f_Port]);
DefaultPort := f_Port;
ConnectTimeout := f_ConnectTimeout;
SSLOptions
.
Method := sslvTLSv1;
SSLOptions
.
Mode := sslmUnassigned;
end
;
with
f_SMTP
do
begin
IOHandler := f_SSL;
UseTLS := utUseExplicitTLS;
end
;
f_LastError :=
NIL
;
except
on
E: Exception
do
raise
EClass
.
Create ([self,
'Create'
,
'Ошибка создания почтового курьера!'
,E]);
end
;
end
;
destructor
TSSL_SMTP
.
Destroy;
begin
try
f_Login :=
''
;
f_Password :=
''
;
if
Assigned (f_MSG)
then
FreeAndNil (f_MSG);
if
Assigned (f_SMTP)
then
FreeAndNil (f_SMTP);
if
Assigned (f_SSL)
then
FreeAndNil (f_SSL);
inherited
Destroy;
except
on
E: Exception
do
raise
EClass
.
Create ([self,
'Destroy'
,
'Ошибка уничтожения почтового курьера!'
,E]);
end
;
end
;
class
function
TSSL_SMTP
.
Send (anArgs:
array
of
const
) :
Boolean
;
var
OBJ : TSSL_SMTP;
begin
Result :=
TRUE
;
try
OBJ := TSSL_SMTP
.
Create (anArgs);
if
Assigned (OBJ)
then
try
Result := OBJ
.
Send;
finally
FreeAndNil (OBJ);
end
;
except
on
E: Exception
do
raise
EClass
.
Create ([self,
'Send'
,
'Ошибка отправки почты курьером!'
,E]);
end
;
end
;
function
TSSL_SMTP
.
Send :
Boolean
;
begin
Result :=
TRUE
;
try
if
( f_Host =
''
)
then
raise
Exception
.
Create (
'Не указан SMTP-сервер!'
);
if
( f_Port =
0
)
then
raise
Exception
.
Create (
'Не указан порт работы SMTP-протокола!'
);
if
( f_ToAddresses =
''
)
then
raise
Exception
.
Create (
'Не указан получатель письма!'
);
with
f_SMTP
do
try
try
Connect();
Send (f_MSG);
ProcessMessages;
finally
Disconnect;
end
;
except
on
E: Exception
do
begin
Result :=
FALSE
;
f_LastError := E;
end
;
end
;
except
on
E: Exception
do
raise
EClass
.
Create ([self,
'Send'
,
'Ошибка отправки почты курьером!'
,E]);
end
;
end
;
procedure
TSSL_SMTP
.
SetHost (
const
aValue:
String
);
***
procedure
TSSL_SMTP
.
SetPort (
const
aValue:
Word
);
***
procedure
TSSL_SMTP
.
SetLogin (
const
aValue:
String
);
***
procedure
TSSL_SMTP
.
SetPassword (
const
aValue:
String
);
***
procedure
TSSL_SMTP
.
SetFromAddress (
const
aValue:
String
);
***
procedure
TSSL_SMTP
.
SetToAddresses (
const
aValue:
String
);
***
procedure
TSSL_SMTP
.
SetSubject (
const
aValue:
String
);
***
procedure
TSSL_SMTP
.
SetMessage (
const
aValue:
String
);
***
function
TSSL_SMTP
.
GetLastError :
String
;
***
procedure
TSSL_SMTP
.
SetConnectTimeout (
const
aValue:
LongWord
);
***
end
.