Send e-mails via WinSock API?
Материал из DRKB
unit SMTP_Connections;
// *********************************************************************
// Unit Name : SMTP_Connections *
// Author : Melih SARICA (Non ZERO) *
// Date : 01/17/2004 *
//**********************************************************************
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.
{***************************************************}
{ How to use it}
{***************************************************}
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; // to output server feedback
// ..........................
MailServer := 'mail.xyz.net';
uname := 'username';
upass := 'password';
mFrom := 'user@xyz.net';
mFromName := 'forename surname';
mToName := '';
Subject := 'Your Subject';
// ..........................
mto := TStringList.Create;
mbody := TStringList.Create;
try
mto.Add('anybody@xyz.net');
mbody.Add('Test Mail');
// Send Mail.................
_authSendMail(MailServer, uname, upass, mFrom, mFromName,
mToName, Subject, mto, mbody);
// ..........................
finally
mto.Free;
mbody.Free;
end;
end;
end.
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 03405
function _RegReadString(_hkey: LongInt; const ValueName: string;
var Value: string; const SubKey: string): Boolean;
var
Key: HKey;
BufLen, Typed: DWord;
begin
Result := False;
Value := EmptyStr;
if RegOpenKeyEx(_hkey, PChar(subkey), 0, KEY_READ, Key) = ERROR_SUCCESS then
begin
Typed := REG_SZ;
BufLen := $FFFF;
SetLength(Value, BufLen);
if RegQueryValueEx(Key, PChar(ValueName),
nil, @Typed, @Value[1], @BufLen) = ERROR_SUCCESS then
begin
if BufLen > 0 then
SetLength(Value, BufLen-1)
else
Value := EmptyStr;
Result := True;
end;
RegCloseKey(Key);
end;
end;
function _HostToIP(Name: string): string;
var
wsdata: TWSAData;
hostName: array [0..255] of Char;
hostEnt: PHostEnt;
addr: PChar;
begin
WSAStartup($0101, wsdata);
gethostname(hostName, SizeOf(hostName));
StrPCopy(hostName, Name);
hostEnt := gethostbyname(hostName);
if Assigned(hostEnt) then
begin
if Assigned (hostEnt^.h_addr_list) then
begin
addr := hostEnt^.h_addr_list^;
if Assigned(addr) then
begin
Result := Format('%d.%d.%d.%d',
[Byte(addr [0]), Byte(addr[1]), Byte(addr[2]), Byte(addr [3])]);
end;
end;
end;
WSACleanup;
end;
function GetSMTPServer: string;
var
s, j: string;
begin
Result := '';
_regreadstring(hkey_current_user, 'Default Mail Account', s,
'Software\Microsoft\Internet Account Manager');
if s = '' then exit;
_regreadstring(hkey_current_user, 'SMTP Server', j,
'Software\Microsoft\Internet Account Manager\Accounts\' + s);
Result := j;
end;
procedure SendStr(Sock: Cardinal; str: String);
var
I: Integer;
begin
for I := 1 to Length(str) do
if send(sock, str[I], 1, 0) = SOCKET_ERROR then exit;
end;
procedure ConnectAndSend(from, _to, st: string);
var
wsadata: TWSADATA;
sin: TSockAddrIn;
sock: TSocket;
MySmtp : String;
iaddr: Integer;
buf: array[0..255] of char;
begin
MySmtp := _HostToIP(getsmtpserver);
WSAStartUp(257, wsadata);
sock := socket(AF_INET, SOCK_STREAM, IPPROTO_IP);
sin.sin_family := AF_INET;
htons(25);
sin.sin_port := htons(25);
iaddr := inet_addr(PChar(MySmtp));
sin.sin_addr.S_addr := iaddr;
connect(sock, sin, SizeOf(sin));
recv(sock, buf, SizeOf(buf), 0);
sendstr(sock, 'HELO google.com' + #13#10);
recv(sock, buf, SizeOf(buf), 0);
sendstr(sock, 'MAIL FROM: ' + from + #13#10);
recv(sock, buf, SizeOf(buf), 0);
sendstr(sock, 'RCPT TO: ' + _to + #13#10);
recv(sock, buf, SizeOf(buf), 0);
sendstr(sock, 'DATA' + #13#10);
recv(sock, buf, SizeOf(buf), 0);
sendstr(sock, st);
sendstr(sock, #13#10'.'#13#10);
recv(sock, buf, SizeOf(buf), 0);
sendstr(sock, 'QUIT'#13#10);
recv(sock, buf, SizeOf(buf), 0);
closesocket(sock);
end;
Author: TauxCanolf
Source: http://forum.sources.ru
ID: 03406