smtp with Tthread
suleiman
Hello All
дайте пожалуста пример как отправить почту испльзуя класс Тthread.
Bye
suleiman <sule...@gosmet.sp.ru> Sun, 16 Oct 2005 10:10:14 +0430
=== Posted with Qusnetsoft NewsReader 2.2.0.8
suleiman
Reply to message from suleiman <sule...@gosmet.sp.ru> (Sun, 16 Oct 2005
11:13:50) about "smtp with Tthread":
s> Hello All
s> дайте пожалуста пример как отправить почту испльзуя класс Тthread.
т.е idsmtp с Tthread-ом
спасибо !
s> Bye
s> suleiman <sule...@gosmet.sp.ru> Sun, 16 Oct 2005 10:10:14 +0430
Bye
suleiman <sule...@gosmet.sp.ru> Sun, 16 Oct 2005 10:36:48 +0430
Igor Yegorkin
Hi, suleiman <sule...@gosmet.sp.ru>
> дайте пожалуста пример как отправить почту испльзуя класс Тthread.
Заверни этот модуль в Thread:
unit SMTP;
interface
uses Windows, SysUtils, ScktComp;
const
CRLF=#13#10;
type
TSendMailPack = record
SMTPHost:string;
SMTPPort:Word;
MailLogin:string;
Password:string;
MailFrom:string;
MailTo:string;
Subject:string;
MessageText:string;
end;
function SendOneEMail(const SendMailPack:TSendMailPack):Boolean;
implementation
uses Main;
const
MessageHeader=
{1}'Date: %s'#13#10+
{2}'From: "I" <%s>'#13#10+
'X-Mailer: The Bat! (v1.62i) Business'#13#10+
{3}'Reply-To: <%s>'#13#10+
'Organization: FBI'#13#10+
'X-Priority: 3 (Normal)'#13#10+
{4}'Message-ID: %s'#13#10+
{5}'To: <%s>'#13#10+
{6}'Subject: %s'#13#10+
'MIME-Version: 1.0'#13#10+
'Content-Type: text/plain; charset=koi8-r'#13#10+
'Content-Transfer-Encoding: 8bit'#13#10+
{7}#13#10'%s'; // после заголовка перед текстом должна быть пустая строка
var
SockSMTP:TClientSocket;
SocketRecieveBuffer:string;
function StrToIntPosDefZero(const s:string; var p:Integer):Integer;
var a:Integer;
begin
while (s[p]<'0')or(s[p]>'9') do Inc(p); a:=p;
while (s[p]>='0')and(s[p]<='9') do Inc(p);
Val(Copy(s,a,p-a),Result,a);
if a<>0 then Result:=0;
end;
function EncodeBase64(Value:string):string;
const Lkp64='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=';
var c:byte; n:integer; Count:integer; DOut:array[0..3] of Byte;
begin
Result:=EmptyStr;
Count:=1;
while Count<=Length(Value) do
begin
c:=Ord(Value[Count]);
Inc(Count);
DOut[0]:=(c and $FC) shr 2;
DOut[1]:=(c and $03) shl 4;
if Count<=Length(Value) then
begin
c:=Ord(Value[Count]);
Inc(Count);
DOut[1]:=DOut[1]+(c and $F0) shr 4;
DOut[2]:=(c and $0F) shl 2;
if Count<=Length(Value) then
begin
c:=Ord(Value[Count]);
Inc(Count);
DOut[2]:=DOut[2]+(c and $C0) shr 6;
DOut[3]:=(c and $3F);
end
else
begin
DOut[3]:=$40;
end;
end
else
begin
DOut[2]:=$40;
DOut[3]:=$40;
end;
for n:=0 to 3 do
Result:=Result+Lkp64[DOut[n]+1];
end;
end;
function RecieveStringCRLF(var s:string):Boolean;
const MailTimeOut=1000*60; // одна минута
var EndStr:Integer; StartTick:LongWord; TimeOk:Boolean;
begin
StartTick:=GetTickCount;
repeat
EndStr:=Pos(CRLF,SocketRecieveBuffer); // ждём CRLF
if EndStr>0 then
begin
Inc(EndStr); // прихватить CRLF полностью
s:=Copy(SocketRecieveBuffer,1,EndStr);
Delete(SocketRecieveBuffer,1,EndStr);
end
else
begin
Sleep(9);
SocketRecieveBuffer:=SocketRecieveBuffer+SockSMTP.Socket.ReceiveText;
end;
TimeOk:=GetTickCount-StartTick<LongWord(MailTimeOut);
until (EndStr>0)or(not TimeOk); // ждём CRLF
Result:=TimeOk;
if not TimeOk then raise Exception.Create('Data receive timeouted');
end;
function GetDateTime:string;
begin // 'Sun, 10 Apr 2005 18:10:47 +0300';
Result:=FormatDateTime('ddd, dd mmm yyyy hh":"nn":"ss +0300',Now);
end;
function SendOneEMail(const SendMailPack:TSendMailPack):Boolean;
var LastServResponse,MessID,MailHeadBody:string;
function SendStringCRLF(Str:string):Boolean;
begin
Result:=False;
try
Str:=Str+CRLF;
SockSMTP.Socket.SendText(Str);
Result:=True;
except
end;
end;
function SMTPRecvReply:Integer;
var a:Integer;
begin
repeat
if RecieveStringCRLF(LastServResponse) then
begin
a:=1; Result:=StrToIntPosDefZero(LastServResponse,a);
end
else begin Result:=-1; Exit; end;
until LastServResponse[a]<>'-'; // даже при "250" там есть CRLF, AV не будет
end;
function AuthLogin:Boolean;
begin
Result:=False;
SendStringCRLF('AUTH LOGIN');
if SMTPRecvReply<>334 then Exit;
SendStringCRLF(Encodebase64(SendMailPack.MailLogin));
if SMTPRecvReply<>334 then Exit;
SendStringCRLF(Encodebase64(SendMailPack.Password));
if SMTPRecvReply<>235 then Exit;
Result:=True;
end;
var OutOfSend,Auth:Boolean; Step:integer;
begin
Result:=False;
with SendMailPack do
try
MessID:='<'+FormatDateTime('yyyymmddhhnnss',Now)+'.'+
IntToHex(Random(High(Integer)),8)+'.'+MailFrom+'>';
MailHeadBody:=Format(MessageHeader,
[GetDateTime,MailFrom,MailTo,MessID,MailTo,Subject,MessageText]);
OutOfSend:=False;
with SockSMTP do
begin
Close;
Host:=SMTPHost;
Port:=SMTPPort;
SocketRecieveBuffer:=EmptyStr;
Open;
end;
Step:=0; Auth:=(MailLogin<>EmptyStr);
if SockSMTP.Socket.Connected then
repeat
case SMTPRecvReply of
220: if Auth then
SendStringCRLF('EHLO there') // EHLO нужно для аутентификации
else SendStringCRLF('HELO there'); // нет логина, не нужна проверка
250,251:
case Step of
0: begin if Auth then AuthLogin; SendStringCRLF('MAIL
FROM:'+MailFrom);Inc(Step); end;
1: begin SendStringCRLF('RCPT TO:'+MailTo);Inc(Step); end;
2: begin SendStringCRLF('DATA');Inc(Step); end;
3: begin SendStringCRLF('QUIT');Inc(Step); end;
4: OutOfSend:=True; // явно выйти, если сервер странный
end;
354:
begin // в ответ на подтверждение DATA отправляем само письмо
SendStringCRLF(MailHeadBody); // отправить тело письма (заголовок+текст)
SendStringCRLF('.'); // конец передачи письма; CRLF добав. автоматич.
end;
221:begin OutOfSend:=True; Result:=True end;
else // прекратить передачу при неожиданном ответе
raise Exception.Create('Can''t send e-mail: '+LastServResponse);
end;
until OutOfSend;
SockSMTP.Close;
except
on E:Exception do
Frame.reLog.Lines.Add('SMTP error: '+E.Message);
end;
end;
initialization
SockSMTP:=TClientSocket.Create(nil);
SockSMTP.ClientType:=ctBlocking; // иначе работать не будет
finalization
SockSMTP.Free;
end.