Une unité appelant wsock32.dll à adapter pour D2009

Question

Voici une unité que je ne peux pas utiliser correctement sur Delphi 2009. Je vous donne le code original qui transmet correctement les données lors de la compilation avec Delphi 2007. Ansifying the code for Delphi 2009 me donne une connexion au serveur mais aucune donnée n'est transmise et aucun feedback). Merci.

unit SMTP_Connections2007; 
// ********************************************************************* 
//  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, 587) = 250 then //port is 587 
    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. 

Voici un code pour faire un essai:

unit Unit1; 

interface 

uses 
    Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, 
    Dialogs, StdCtrls; 

type 
    TForm1 = class(TForm) 
    Button1: TButton; 
    Memo1: TMemo; 
    // Button1: TButton; 
    // Memo1: TMemo; 
    procedure Button1Click(Sender: TObject); 
    private 
    { Private declarations } 
    public 
    { Public declarations } 
    end; 

var 
    Form1: TForm1; 

implementation 

{$R *.dfm} 

uses 
    SMTP_Connections2007; 

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 := 'somename.servername'; 
    uname := 'username'; 
    upass := 'password'; 
    mFrom := 'someuser@xyz.net'; 
    mFromName := 'forename surname'; 
    mToName := ''; 
    Subject := 'Your Subject'; 
    //.......................... 
    mto := TStringList.Create; 
    mbody := TStringList.Create; 
    try 
    mto.Add('destination_emailaddress'); 
    mbody.Add('Test Mail'); 
    //Send Mail................. 
    _authSendMail(MailServer, uname, upass, mFrom, mFromName, mToName, Subject, mto, mbody); 
    //.......................... 
    finally 
    mto.Free; 
    mbody.Free; 
    end; 
end; 

end. 

Answer 1

J'ai testé votre code et l'ai testé avec Delphi2009, cela fonctionne sans aucun problème. J'ai réussi à envoyer des courriels de gmx.com à mail.google.com.

J'ai changé la chaîne en AnsiString, Char en AnsiChar et PChar en PAnsiChar. Peut-être avez-vous simplement oublié d'ansifier Char ou PChar?

Answer 2

Une chose à considérer serait la bibliothèque TCP/IP Synapse, dont la dernière version de développement SVN compile et va à l'encontre de Delphi 2009 avec Unicode et a toutes les fonctionnalités de votre unité et peut facilement effectuer les étapes de votre programme de test.