Parsi Coders

با سورس زیر یاد میگیرید که از طریق API وینساک ('wsock32.dll') توسط زبان دلفی ایمیل ارسال کنید.
English:
Send e-mails via WinSock API ('wsock32.dll
سورس کد :
کد:
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 / Wie verwende ich die Unit?}

{***************************************************}

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.
Amin_Mansouri
