soonmail.pas

Delphi环境下用纯API完成的匿名邮件发送单元。涉及到本地DNS读取、MX解析以及利用SOCK按照SMTP约定发送EMAIL的单元。非常适合做一些程序的反馈单元。而不用担心内存会泄露你的邮箱密码。

{
Send Posthaste_Email Unit

Author   : FI7KE
HomePage : http://www.fi7ke.com

Usage    : SendMail('[e-mail]', [e-mail], 'Subject', 'Mail Text...');
}

unit SoonMail;

interface

uses WinSock;

procedure SendMail(MyEmail, ToMail, subject, Content: string);

implementation

const
  EOF = #13#10;

var
  WSAData: TWSAData;

type
  TIPAddressString = array[0..4 * 4 - 1] of Char; //用来放IP的

  PIPAddrString = ^TIPAddrString;
  TIPAddrString = record
    Next: PIPAddrString;
    IPAddress: TIPAddressString;
    IPMask: TIPAddressString;
    Context: Integer;
  end;

  PFixedInfo = ^TFixedInfo;
  TFixedInfo = record
    FI7KE: array[0..262] of Char; //纯粹占位用的
    CurrentDNSServer: PIPAddrString;
    DNSServerList: TIPAddrString;
  end;

  PMXQuery = ^MXQuery;
  MXQuery = record
    ID: WORD;
    Flag: WORD;
    Question: WORD;
    Answer: WORD;
    Author: WORD;
    Addition: WORD;
    secB: BYTE;
    secE: BYTE;
    FType: WORD;
    Fclass: WORD;
  end;

  ip_mreq = record
    imr_multiaddr: in_addr;
    imr_interface: in_addr;
  end;
  TIpMReq = ip_mreq;
  PIpMReq = ^ip_mreq;

  TClientSocket = class(TObject)
  protected
    FSocket: TSocket;
  public
    procedure Connect(Address: string);
    procedure Disconnect;
    function SendBuffer(Buffer: string): integer;
    function ReceiveBuffer: integer;
  end;


function GetNetworkParams(FI: PFixedInfo; var BufLen: Integer): Integer;
  stdcall; external 'iphlpapi.dll' Name 'GetNetworkParams';

function CharUpper(lpsz: PChar): PChar; stdcall external 'user32.dll' Name 'CharUpperA';


function StrToInt(cStr: string): Longint;
var
  Code: Integer;
begin
  val(cStr, Result, Code);
end;


function IntToHex(N: LongWord; Digits: Cardinal): string;
asm
        PUSH    ESI
        PUSH    EDI
        PUSH    EBX
        MOV     ESI,EAX
        MOV     EDI,ECX
        MOV     EBX,EDX
        MOV     EAX,ECX
        MOV     ECX,EDX
        XOR     EDX,EDX
        CALL    System.@LStrFromPCharLen
        MOV     EAX,ESI
        MOV     ESI,[EDI]
        MOV     EDI,ESI
@@lp1:  DEC     EBX
        JS      @@lp2
        MOV     DL,AL
        AND     DL,$0F
        CMP     DL,$09
        JA      @@bd
        ADD     DL,$30
        MOV     BYTE PTR [ESI],DL
        INC     ESI
        SHR     EAX,4
        JNE     @@lp1
        JMP     @@bl
@@bd:   ADD     DL,$37
        MOV     BYTE PTR [ESI],DL
        INC     ESI
        SHR     EAX,4
        JNE     @@lp1
@@bl:   DEC     EBX
        JS      @@lp2
        MOV     BYTE PTR [ESI],$30
        INC     ESI
        JMP     @@bl
@@lp2:  DEC     ESI
        CMP     EDI,ESI
        JAE     @@qt
        MOV     AH,BYTE PTR [EDI]
        MOV     AL,BYTE PTR [ESI]
        MOV     BYTE PTR [ESI],AH
        MOV     BYTE PTR [EDI],AL
        INC     EDI
        JMP     @@lp2
@@qt:   POP     EBX
        POP     EDI
        POP     ESI
end;


function StrToHex(const Value: string; By: Integer): string;
var
  i, Index: Integer;
begin
  Result := '';
  for i := 1 to Length(Value) do
  begin
    Index := Ord(Value[i]);
    Result := Result + IntToHex(Index, By);
  end;
end;


function StrCopy(Dest: PChar; const Source: PChar): PChar; assembler; //Str To array
asm
        PUSH    EDI
        PUSH    ESI
        MOV     ESI,EAX
        MOV     EDI,EDX
        MOV     ECX,0FFFFFFFFH
        XOR     AL,AL
        REPNE   SCASB
        NOT     ECX
        MOV     EDI,ESI
        MOV     ESI,EDX
        MOV     EDX,ECX
        MOV     EAX,EDI
        SHR     ECX,2
        REP     MOVSD
        MOV     ECX,EDX
        AND     ECX,3
        REP     MOVSB
        POP     ESI
        POP     EDI
end;


function StrLen(const Str: PChar): Cardinal; assembler; //取数据包长度
asm
        MOV     EDX,EDI
        MOV     EDI,EAX
        MOV     ECX,0FFFFFFFFH
        XOR     AL,AL
        REPNE   SCASB
        MOV     EAX,0FFFFFFFEH
        SUB     EAX,ECX
        MOV     EDI,EDX
end;


function UpperCase(const S: string): string;
begin
  Result := CharUpper(Pchar(S));
end;


function AllocMem(Size: Cardinal): Pointer;
begin
  GetMem(Result, Size);
  FillChar(Result^, Size, 0);
end;


function GetDNSAddress: string; //获取本地DNS
var
  FI: PFixedInfo;
  Size: Integer;
  DNS: PIPAddrString;

begin
  Size := 1024;
  GetMem(FI, Size);

  if GetNetworkParams(FI, Size) <> 0 then
  begin
    Result := 'FI7KE';
    Exit;
  end
  else
  begin
    DNS := @FI^.DNSServerList;
    Result := DNS^.IPAddress;
  end;

  FreeMem(FI);
end;


procedure CreateQuery(MyQuery: PMXQuery; sAddr: string); //构造UDP查询包
var
  pData, pTemp: PChar;
  Len, I: Integer;
  Pof: PWord;
begin
  FillChar(MyQuery^, sizeof(MXQuery) + Length(sAddr), 0);
  MyQuery^.ID := $781;
  MyQuery^.Flag := $1; //标准查询
  MyQuery^.Question := $100;
  MyQuery^.Answer := $0;
  MyQuery^.Author := $0;
  MyQuery^.Addition := $0;
  Len := Length(sAddr) + 2;
  pData := AllocMem(Len);
  Inc(pData);
  Move(sAddr[1], pData^, Length(sAddr));
  Dec(pData);
  pTemp := pData;
  I := Pos('.', sAddr);

  while I > 0 do
  begin
    pTemp^ := Chr(I - 1);
    Inc(pTemp, I);
    Delete(sAddr, 1, i);
    I := Pos('.', sAddr);
  end;
  
  pTemp^ := Chr(Length(sAddr));
  Inc(pTemp, Length(sAddr) + 1);
  pTemp^ := #0;
  pTemp := @MyQuery^.secB;
  Move(pData^, pTemp^, Len);
  FreeMem(pData);
  Pof := PWord(pTemp + Len);
  Pof^ := htons($0F);
  Inc(pof);
  Pof^ := htons(1);
end;


function PickPack(pbuf: PChar): string; //处理返回的UDP包
var
  p: PChar;
  I, N: Integer;
  Temp: string;
begin
  p := pbuf;
  INC(P, 11);

  while StrToHex(string(P[1]), 1) <> '0' do
  begin
    N := StrToInt(StrToHex(string(P[1]), 1));
    Temp := Temp + '.';
    for I := 1 to N do
    begin
      INC(P);
      Temp := Temp + string(P[1]);
    end;
    INC(P);
  end;

  if POS('GMAIL.COM', UpperCase(Temp)) > 0 then //Gmail的返回信息与其它的有些不同,懒得深入了,将就一下
  begin
    Result := 'gsmtp185.google.com';
    Exit;
  end;

  INC(P, 19);

  while StrToHex(string(P[1]), 2) <> 'C0' do
  begin
    N := StrToInt(StrToHex(string(P[1]), 1));

    if N = 0 then
    begin
      Result := Result;
      Exit;
    end;

    Result := Result + '.';
    for I := 1 to N do
    begin
      INC(P, 1);
      Result := Result + string(P[1]);
    end;
    INC(P);
  end;

  Result := Result + Temp;
end;


function GetEMailServer(EMailServer: string): string; //获取目标服务器IP
var
  wsa: TWSAData;
  sock: TSocket;
  remote: TSockAddr;
  mcast: ip_mreq;
  buffer: array[1..4096] of Char;
  Len: integer;
  I: Integer;
  Query: PMXQuery;
  Temp: string;
begin
  if GetDNSAddress <> 'FI7KE' then
  begin
    WSAStartup($0202, wsa);
    sock := socket(AF_INET, SOCK_DGRAM, 0);

    remote.sin_family := AF_INET;
    remote.sin_port := htons(53);
    remote.sin_addr.S_addr := inet_addr(PChar(GetDNSAddress));

    Query := AllocMem(sizeof(MXQuery) + Length(EMailServer));
    CreateQuery(Query, EMailServer);

    sendto(sock, Query^, SizeOf(MXQuery) + Length(EMailServer), 0, remote, sizeof(remote));

    I := SizeOf(Remote);
    Len := RecvFrom(Sock, buffer, sizeof(buffer), 0, Remote, I);

    Temp := PickPack(@Buffer);
    if Temp[1] = '.' then
      Temp := Copy(Temp, 2, Length(Temp));

    Result := Temp;
  end
  else
    Result := 'FI7KE';

  closesocket(sock);
  WSACleanup;
end;


procedure TClientSocket.Connect(Address: string); //连接目标邮件服务器
var
  SockAddrIn: TSockAddrIn;
  HostEnt: PHostEnt;
begin
  Disconnect;
  FSocket := Winsock.socket(PF_INET, SOCK_STREAM, IPPROTO_TCP);
  SockAddrIn.sin_family := AF_INET;
  SockAddrIn.sin_port := htons(25);
  SockAddrIn.sin_addr.s_addr := inet_addr(PChar(Address));
  if SockAddrIn.sin_addr.s_addr = INADDR_NONE then
  begin
    HostEnt := Gethostbyname(PChar(Address));
    if HostEnt = nil then
    begin
      Exit;
    end;
    SockAddrIn.sin_addr.s_addr := Longint(PLongint(HostEnt^.h_addr_list^)^);
  end;
  Winsock.Connect(FSocket, SockAddrIn, SizeOf(SockAddrIn));
end;


procedure TClientSocket.Disconnect; //关闭套字节
begin
  Closesocket(FSocket);
end;


function TClientSocket.SendBuffer(Buffer: string): integer; //发送数据
var
  Buf: array[0..1024] of char;
begin
  StrCopy(Buf, PChar(Buffer));
  Result := send(FSocket, Buf, StrLen(Buf), 0);
  if Result = SOCKET_ERROR then
  begin
    if (WSAGetLastError = WSAEWOULDBLOCK) then
    begin
      Result := -1;
    end
    else
    begin
      Disconnect;
    end;
  end;
end;


function TClientSocket.ReceiveBuffer: integer; //接收数据
var
  Buf: array[0..1024] of char;
begin
  Result := recv(FSocket, Buf, 1025, 0);
end;


procedure SendMail(MyEmail, ToMail, subject, Content: string); //投递邮件
var
  MySock: TClientSocket;
begin

  MySock := TClientSocket.Create;
  MySock.Connect(GetEmailServer(Copy(Tomail, pos('@', Tomail) + 1, LengTh(Tomail))));
  MySock.ReceiveBuffer;

  MySock.SendBuffer('HELO FI7KE' + EOF);
  MySock.ReceiveBuffer;

  MySock.SendBuffer('MAIL FROM:<' + MyEmail + '>' + EOF);
  MySock.ReceiveBuffer;

  MySock.SendBuffer('RCPT TO:<' + TOMail + '>' + EOF);
  MySock.ReceiveBuffer;

  MySock.SendBuffer('DATA' + EOF);
  MySock.ReceiveBuffer;

  MySock.SendBuffer
    (
    'FROM:<' + MyEmail + '>' + EOF +
    'TO:<' + ToMail + '>' + EOF +
    'SUBJECT:' + Subject + EOF + EOF +
    Content + EOF +
    '.' + EOF
    );
  MySock.ReceiveBuffer;

  MySock.SendBuffer('QUIT' + EOF);
  MySock.ReceiveBuffer;

  MySock.Disconnect;
end;


initialization
  WSAStartUp($0202, WSAData);

finalization
  WSACleanup;


end.