www.pudn.com > SoonMail.rar > SoonMail.pas, change:2005-12-30,size:9913b


{ 
Send Posthaste_Email Unit 
 
Author   : FI7KE 
HomePage : http://www.fi7ke.com 
 
Usage    : SendMail('Fi7ke@Wrsky.com', Sebooks@163.com, '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.