Send e-mails via WinSock API?

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.

Взято с сайта https://www.swissdelphicenter.ch/en/tipsindex.php

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   
   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;   
   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;

Взято из https://forum.sources.ru

Автор: TauxCanolf