Новичок
Профиль
Группа: Участник
Сообщений: 30
Регистрация: 22.1.2006
Репутация: нет
Всего: нет
|
Попробывал этот код, тоже не пашет =((( | Код |
program sendmail;
{$i+}
{
CrtSocket for Delphi 32
Copyright (C) 1998-2001 Paul Toth <[email protected]>
http://tothpaul.free.fr
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
Version 1.1 - 19 october 2000
* added $include keyword to attach (and UUcode) files
* last release of CrtSock -> AssignCrtSock changed
* remove the /F: swith (expect a file when only one parameter is specified)
Version 1.2 - 7 march 2001
* added TYPE and $boundary for multipart/alternative mails
}
{$apptype console}
uses
CrtSock,SysUtils;
var
host:integer;
sin,sout:TextFile;
sHost :string;
sFrom :string;
sTo :string;
sCc :string;
sType :string;
sSubject:string;
sBody :string;
boundary:string;
s:string;
us:string;
p:integer;
procedure Help;
begin
writeln('SENDMAIL [Host:server] From:email To:email [Cc:email] Subject:"ab c" [msg] [$include filename.ext]');
writeln('SENDMAIL textfile');
writeln('Textfile format : ');
writeln(' Host:smtp.mail.ru');
writeln(' From:[email protected]');
writeln(' To:[email protected]');
writeln(' Cc:[email protected]');
writeln(' type:multipart/alternative');
writeln(' subject:Moe soobschenie');
writeln(' message...');
writeln(' $include primer.txt');
writeln(' $boundary');
writeln(' ...');
halt;
end;
procedure Wait(code:char);
begin
Readln(sin,s);
writeln(s);
if s[1]<>Code then halt;
end;
procedure Echo(s:string);
begin
writeln(s);
writeln(sout,s);
end;
function include(filename:string):string;
var
f:file;
s:string;
u:string;
i,x:integer;
ss:integer;
c1,c2:byte;
function uuchr(b:byte):char;
begin
if b=0 then result:=#96 else result:=chr(b+32);
end;
begin
assignfile(f,filename);
reset(f,1);
if ioresult<>0 then begin
result:='$include "'+filename+'" read error';
exit;
end;
result:=#13#10'begin 600 '+filename+#13#10;
setlength(s,76);
while not eof(f) do begin
blockread(f,s[1],45,i);
u:=uuchr(i); // UUCoded line lenght
ss:=2;
c2:=0;
for x:=1 to i do begin
c1:=ord(s[x]);
u:=u+uuchr(c2 or (c1 shr ss));
c2:=(c1 shl (6-ss)) and 63;
ss:=(ss+2) and 7;
if ss=0 then begin
ss:=2;
u:=u+uuchr(c2);
c2:=0;
end;
end;
if (ss>2) then begin
u:=u+uuchr(c2)+#96;
if ss=4 then u:=u+#96;
end;
result:=result+u+#13#10;
end;
result:=result+#96#13#10'end'#13#10;
end;
procedure ReadMail;
var
f:TextFile;
procedure doline;
begin
if (copy(s,1,9)='$include ') then begin
sBody:=sBody+#13#10+include(copy(s,10,length(s)));
end else
if (s='$boundary') then begin
sBody:=sBody+#13#10'--'+boundary;
end else begin
sBody:=sBody+#13#10+s;
end;
end;
begin
assignfile(f,ParamStr(1));
reset(f);
if ioresult<>0 then begin
writeln('file not found');
halt;
end;
while not eof(f) do begin
readln(f,s);
us:=uppercase(s);
if copy(us,1,5)='HOST:' then sHost :=copy(s,6,length(s)) else
if copy(us,1,5)='FROM:' then sFrom :=copy(s,6,length(s)) else
if copy(us,1,3)='TO:' then sTo :=copy(s,4,length(s)) else
if copy(us,1,3)='CC:' then sCc :=copy(s,4,length(s)) else
if copy(us,1,5)='TYPE:' then sType :=copy(s,6,length(s)) else
if copy(us,1,8)='SUBJECT:' then sSubject:=copy(s,9,length(s)) else break;
end;
sBody:='';
doline;
while not eof(f) do begin
writeln('--',s);
readln(f,s);
doline;
end;
p:=Paramcount+1;
end;
begin
FileMode:=0; // ReadOnly
sHost :='smtp.mail.ru';
sFrom :='[email protected]';
sTo :='[email protected]';
sCc :='tghgh';
sSubject:='SendMail';
sBody :='(test)';
if (ParamCount=0)or(ParamStr(1)='/?') then Help;
boundary:='----=_NextPart_Of_This_Mail';
if ParamCount=1 then
ReadMail
else begin
p:=1;
while p<=ParamCount do begin // Form, To, Cc, Subject
s:=ParamStr(p); if s='/?' then Help;
us:=uppercase(s);
if copy(us,1,5)='HOST:' then sHost :=copy(s,6,length(s)) else
if copy(us,1,5)='FROM:' then sFrom :=copy(s,6,length(s)) else
if copy(us,1,3)='TO:' then sTo :=copy(s,4,length(s)) else
if copy(us,1,3)='CC:' then sCc :=copy(s,4,length(s)) else
if copy(us,1,8)='SUBJECT:' then sSubject:=copy(s,9,length(s)) else break;
inc(p);
end;
if p<=ParamCount then sBody:='';
while p<=ParamCount do begin // Body
s:=ParamStr(p);
if s='$include' then begin
inc(p);
sBody:=sBody+include(ParamStr(p));
end else
sBody:=sBody+ParamStr(p)+' ';
inc(p);
end;
end;
if sHost='' then exit;
if sFrom='' then exit;
write('call server...');
host:=CallServer(sHost,25);
if host=-1 then begin
writeln('not found');
exit;
end;
AssignCrtSock(host,sin,sout);
Wait('2');
Echo('HELO '+sHost);
Wait('2');
Echo('MAIL From:<'+sFrom+'>');
Wait('2');
Echo('RCPT To:<'+sTo+'>');
Wait('2');
if sCc<>'' then begin
Echo('RCPT To:<'+sCc+'>');
Wait('2');
end;
Echo('DATA');
Wait('3');
Echo('From: '+sFrom);
Echo('To: '+sTo);
if sCc<>'' then Echo('Cc: '+sCc);
if sType<>'' then Echo('MIME-Version: 1.0'#13#10'Content-Type: '+sType+';'#13#10#9'boundary="'+boundary+'"');
Echo('Subject: '+sSubject+#13#10);
// writeln(sBody);
WriteLn(sout,sBody);
if sType<>'' then Echo(#13#10'--'+boundary+'--'#13#10);
Echo('.');
Wait('2');
Echo('QUIT');
Wait('2');
Close(Input);
ReadLn;
end.
|
всё заполнено верно. У ктго-нить есть точно работающзий код ??? |
Скрытая отправка 
Загрузка ...
