unit SMTP_Connections;
//------------------------------------------
//定义单元
//---------------------------------------------
interface
uses
Classes, StdCtrls;
const
WinSock = 'wsock32.dll';
Internet = 2;
Stream = 1;
fIoNbRead = $4004667F;
WinSMTP = $0001;
LinuxSMTP = $0002;
type
TWSAData =
packed record
wVersion: Word;
wHighVersion: Word;
szDescription:
array[0..256]
of Char;
szSystemStatus:
array[0..128]
of Char;
iMaxSockets: Word;
iMaxUdpDg: Word;
lpVendorInfo: PChar;
end;
PHost = ^THost;
THost =
packed record
Name: PChar;
aliases: ^PChar;
addrtype: Smallint;
Length: Smallint;
addr: ^Pointer;
end;
TSockAddr =
packed record
Family: Word;
Port: Word;
Addr: Longint;
Zeros:
array[0..7]
of Byte;
end;
function WSAStartup(Version:word;
Var Data:TwsaData):integer;
stdcall;
far;
external winsock;
function socket(Family,Kind,Protocol:integer):integer;
stdcall;
far;
external winsock;
function shutdown(Socket,How:Integer):integer;
stdcall;
far;
external winsock;
function closesocket(socket:Integer):integer;
stdcall;
far;
external winsock;
function WSACleanup:integer;
stdcall;
far;
external winsock;
function bind(Socket:Integer;
Var SockAddr:TSockAddr; AddrLen:integer):integer;
stdcall;
far;
external winsock;
function listen(socket,flags:Integer):integer;
stdcall;
far;
external winsock;
function connect(socket:Integer;
Var SockAddr:TSockAddr; AddrLen:integer):integer;
stdcall;
far;
external winsock;
function accept(socket:Integer;
Var SockAddr:TSockAddr;
Var AddrLen:Integer):integer;
stdcall;
far;
external winsock;
function WSAGetLastError:integer;
stdcall;
far;
external winsock;
function recv(socket:integer; data:pchar; datalen,flags:integer):integer;
stdcall;
far;
external winsock;
function send(socket:integer;
var data; datalen,flags:integer):integer;
stdcall;
far;
external winsock;
function gethostbyname(HostName:PChar):PHost;
stdcall;
far;
external winsock;
function WSAIsBlocking:boolean;
stdcall;
far;
external winsock;
function WSACancelBlockingCall:integer;
stdcall;
far;
external winsock;
function ioctlsocket(socket:integer; cmd: Longint;
var arg: longint): Integer;
stdcall;
far;
external winsock;
function gethostname(name:pchar; size:integer):integer;
stdcall;
far;
external winsock;
procedure _authSendMail(MailServer,uname,upass,mFrom,mFromName,mToName,Subject:
string;mto,mbody:TStringList);
function ConnectServer(mhost:
string;mport:integer):integer;
function ConnectServerwin(mhost:
string;mport:integer):integer;
function DisConnectServer:integer;
function Stat:
string;
function SendCommand(Command:
String):
string;
function SendData(Command:
String):
string;
function SendCommandWin(Command:
String):
string;
function ReadCommand:
string;
function encryptB64(s:
string):
string;
var
mconnHandle: Integer;
mFin, mFOut: Textfile;
EofSock: Boolean;
mactive: Boolean;
mSMTPErrCode: Integer;
mSMTPErrText:
string;
mMemo: TMemo;
implementation
uses
SysUtils, Sockets, IdBaseComponent,
IdCoder, IdCoder3to4, IdCoderMIME, IniFiles,Unit1;
var
mClient: TTcpClient;
procedure _authSendMail(MailServer, uname, upass, mFrom, mFromName,
mToName, Subject:
string; mto, mbody: TStringList);
var
tmpstr:
string;
cnt: Integer;
mstrlist: TStrings;
RecipientCount: Integer;
begin
if ConnectServerWin(Mailserver, 25) = 250
then
begin
Sendcommandwin('AUTH LOGIN ');
SendcommandWin(encryptB64(uname));
SendcommandWin(encryptB64(upass));
SendcommandWin('MAIL FROM: ' + mfrom);
for cnt := 0
to mto.Count - 1
do
SendcommandWin('RCPT TO: ' + mto[cnt]);
Sendcommandwin('DATA');
SendData('Subject: ' + Subject);
SendData('From: "' + mFromName + '" <' + mfrom + '>');
SendData('To: ' + mToName);
SendData('Mime-Version: 1.0');
SendData('Content-Type: multipart/related; boundary="Esales-Order";');
SendData(' type="text/html"');
SendData('');
SendData('--Esales-Order');
SendData('Content-Type: text/html;');
SendData(' charset="iso-8859-9"');
SendData('Content-Transfer-Encoding: QUOTED-PRINTABLE');
SendData('');
for cnt := 0
to mbody.Count - 1
do
SendData(mbody[cnt]);
Senddata('');
SendData('--Esales-Order--');
Senddata(' ');
mSMTPErrText := SendCommand(crlf + '.' + crlf);
try
mSMTPErrCode := StrToInt(Copy(mSMTPErrText, 1, 3));
except
end;
SendData('QUIT');
DisConnectServer;
end;
end;
function Stat:
string;
var
s:
string;
begin
s := ReadCommand;
Result := s;
end;
function EchoCommand(Command:
string):
string;
begin
SendCommand(Command);
Result := ReadCommand;
end;
function ReadCommand:
string;
var
tmp:
string;
begin
repeat
ReadLn(mfin, tmp);
if Assigned(mmemo)
then
mmemo.Lines.Add(tmp);
until (Length(tmp) < 4)
or (tmp[4] <> '-');
Result := tmp
end;
function SendData(Command:
string):
string;
begin
Writeln(mfout, Command);
end;
function SendCommand(Command:
string):
string;
begin
Writeln(mfout, Command);
Result := stat;
end;
function SendCommandWin(Command:
string):
string;
begin
Writeln(mfout, Command + #13);
Result := stat;
end;
function FillBlank(Source:
string; number: Integer):
string;
var
a: Integer;
begin
Result := '';
for a := Length(trim(Source))
to number
do
Result := Result + ' ';
end;
function IpToLong(ip:
string): Longint;
var
x, i: Byte;
ipx:
array[0..3]
of Byte;
v: Integer;
begin
Result := 0;
Longint(ipx) := 0;
i := 0;
for x := 1
to Length(ip)
do
if ip[x] = '.'
then
begin
Inc(i);
if i = 4
then Exit;
end
else
begin
if not (ip[x]
in ['0'..'9'])
then Exit;
v := ipx[i] * 10 + Ord(ip[x]) - Ord('0');
if v > 255
then Exit;
ipx[i] := v;
end;
Result := Longint(ipx);
end;
function HostToLong(AHost:
string): Longint;
var
Host: PHost;
begin
Result := IpToLong(AHost);
if Result = 0
then
begin
Host := GetHostByName(PChar(AHost));
if Host <>
nil then Result := Longint(Host^.Addr^^);
end;
end;
function LongToIp(Long: Longint):
string;
var
ipx:
array[0..3]
of Byte;
i: Byte;
begin
Longint(ipx) := long;
Result := '';
for i := 0
to 3
do Result := Result + IntToStr(ipx[i]) + '.';
SetLength(Result, Length(Result) - 1);
end;
procedure Disconnect(Socket: Integer);
begin
ShutDown(Socket, 1);
CloseSocket(Socket);
end;
function CallServer(Server:
string; Port: Word): Integer;
var
SockAddr: TSockAddr;
begin
Result := socket(Internet, Stream, 0);
if Result = -1
then Exit;
FillChar(SockAddr, SizeOf(SockAddr), 0);
SockAddr.Family := Internet;
SockAddr.Port := swap(Port);
SockAddr.Addr := HostToLong(Server);
if Connect(Result, SockAddr, SizeOf(SockAddr)) <> 0
then
begin
Disconnect(Result);
Result := -1;
end;
end;
function OutputSock(
var F: TTextRec): Integer;
far;
begin
if F.BufPos <> 0
then
begin
Send(F.Handle, F.BufPtr^, F.BufPos, 0);
F.BufPos := 0;
end;
Result := 0;
end;
function InputSock(
var F: TTextRec): Integer;
far;
var
Size: Longint;
begin
F.BufEnd := 0;
F.BufPos := 0;
Result := 0;
repeat
if (IoctlSocket(F.Handle, fIoNbRead, Size) < 0)
then
begin
EofSock := True;
Exit;
end;
until (Size >= 0);
F.BufEnd := Recv(F.Handle, F.BufPtr, F.BufSize, 0);
EofSock := (F.Bufend = 0);
end;
function CloseSock(
var F: TTextRec): Integer;
far;
begin
Disconnect(F.Handle);
F.Handle := -1;
Result := 0;
end;
function OpenSock(
var F: TTextRec): Integer;
far;
begin
if F.Mode = fmInput
then
begin
EofSock := False;
F.BufPos := 0;
F.BufEnd := 0;
F.InOutFunc := @InputSock;
F.FlushFunc :=
nil;
end
else
begin
F.Mode := fmOutput;
F.InOutFunc := @OutputSock;
F.FlushFunc := @OutputSock;
end;
F.CloseFunc := @CloseSock;
Result := 0;
end;
procedure AssignCrtSock(Socket:integer;
Var Input,Output:TextFile);
begin
with TTextRec(Input)
do
begin
Handle := Socket;
Mode := fmClosed;
BufSize := SizeOf(Buffer);
BufPtr := @Buffer;
OpenFunc := @OpenSock;
end;
with TTextRec(Output)
do
begin
Handle := Socket;
Mode := fmClosed;
BufSize := SizeOf(Buffer);
BufPtr := @Buffer;
OpenFunc := @OpenSock;
end;
Reset(Input);
Rewrite(Output);
end;
function ConnectServer(mhost:
string; mport: Integer): Integer;
var
tmp:
string;
begin
mClient := TTcpClient.Create(
nil);
mClient.RemoteHost := mhost;
mClient.RemotePort := IntToStr(mport);
mClient.Connect;
mconnhandle := callserver(mhost, mport);
if (mconnHandle<>-1)
then
begin
AssignCrtSock(mconnHandle, mFin, MFout);
tmp := stat;
tmp := SendCommand('HELO bellona.com.tr');
if Copy(tmp, 1, 3) = '250'
then
begin
Result := StrToInt(Copy(tmp, 1, 3));
end;
end;
end;
function ConnectServerWin(mhost:
string; mport: Integer): Integer;
var
tmp:
string;
begin
mClient := TTcpClient.Create(
nil);
mClient.RemoteHost := mhost;
mClient.RemotePort := IntToStr(mport);
mClient.Connect;
mconnhandle := callserver(mhost, mport);
if (mconnHandle<>-1)
then
begin
AssignCrtSock(mconnHandle, mFin, MFout);
tmp := stat;
tmp := SendCommandWin('HELO bellona.com.tr');
if Copy(tmp, 1, 3) = '250'
then
begin
Result := StrToInt(Copy(tmp, 1, 3));
end;
end;
end;
function DisConnectServer: Integer;
begin
closesocket(mconnhandle);
mClient.Disconnect;
mclient.Free;
end;
function encryptB64(s:
string):
string;
var
hash1: TIdEncoderMIME;
p:
string;
begin
if s <> ''
then
begin
hash1 := TIdEncoderMIME.Create(
nil);
p := hash1.Encode(s);
hash1.Free;
end;
Result := p;
end;
end.
//------------------------------------------
// 怎么使用定义好得相关单元
//---------------------------------------------
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 =
class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
SMTP_Connections;
procedure TForm1.Button1Click(Sender: TObject);
var
mto, mbody: TStringList;
MailServer, uname, upass, mFrom, mFromName,
mToName, Subject:
string;
begin
mMemo := Memo1; // 定义相关发送服务器
//..........................
MailServer := 'mail.163.com';
uname := 'username';
upass := 'password';
mFrom := '
[email protected];
mFromName := 'forename surname';
mToName := '';
Subject := 'Your Subject';
//..........................
mto := TStringList.Create;
mbody := TStringList.Create;
try
mto.Add('
[email protected]');
mbody.Add('测试邮件
');
//发送.................
_authSendMail(MailServer, uname, upass, mFrom, mFromName, mToName, Subject, mto, mbody);
//..........................
finally
mto.Free;
mbody.Free;
end;
end;
end.
本文地址：http://com.8s8s.com/it/it4660.htm