Eine Einheit ruft Wsock32.dll für D2009 angepasst werden

Question

Hier eine Einheit kann ich nicht richtig auf Delphi 2009. Ich gebe Ihnen den ursprünglichen Code, der Daten korrekt übertragen, wenn mit Delphi 2007 kompiliert. Answering den Code für Delphi 2009 gibt mir eine Verbindung zum Server, aber keine Daten werden übertragen und keine Rückmeldung). Vielen Dank.

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. 

Hier einige Code, um es zu versuchen:

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

Ich habe Ihren Code bestätigt und mit Delphi2009 getestet, es funktioniert ohne Probleme. Es ist mir gelungen, eine E-Mail von gmx.com an mail.google.com zu senden.

Ich habe String zu AnsiString, Char zu AnsiChar und PChar zu PAnsiChar geändert.

Vielleicht haben Sie einfach vergessen, Char oder PChar zu verbessern?

Answer 2

Eine Sache, die TCP/IP-Bibliothek Synapse, von denen die neueste Entwicklungsversion in SVN zu betrachten wäre kompiliert und läuft gegen Delphi 2009 mit Unicode und hat alle Funktionen in Ihrem Gerät und kann die Schritte Ihres Testprogramms leicht durchführen.