E-Mail senden ohne Indy

[xXFelixXx]

Hallo!

Ich würde gerne aus meinem Programm heraus E-Mails versenden.
Ich würde dies aber gerne ohne Indy und co tun.
Ist das überhaupt möglich und wenn ja, wie?

Danke schon mal, Felix

[Die Muhkuh]

Stichwort: MAPI

[Coder]

mit den älteren delphi Versionen (bis 6) ist das glaube ich nicht mehr möglich, weil die Komponenten zu alt sind.

Wie das mit den neueren ist, weiß ich nicht.


Warum willste das ohne INDY machen?

[xXFelixXx]

Zitat:

Zitat von Coder

Warum willste das ohne INDY machen?

1. Ich hab das nicht auf meinem PC (OK, ich weiß, dass man das downloaden kann :roll: )
2. Ich arbeite an verschiedenen PCs und müsste überall Indy installieren

edit:

Zitat:

Zitat von Coder

mit den älteren delphi Versionen (bis 6) ist das glaube ich nicht mehr möglich, weil die Komponenten zu alt sind.

Keine Sorge, ich verwende D7

Zitat:

Zitat von Die Muhkuh

Stichwort: MAPI

Wo finde ich da vernünftige tutorials/wie geht das...

[Astat]

Zitat:

Zitat von xXFelixXx

Ich würde gerne aus meinem Programm heraus E-Mails versenden.
Ich würde dies aber gerne ohne Indy und co tun.
Ist das überhaupt möglich und wenn ja, wie?

try this.

Delphi-Quellcode:

{------------------------------------------------------------------------------}
{     Created by :          Lanthan Astat                                      }                                         }
{------------------------------------------------------------------------------}
{                           Module Details                                     }
{------------------------------------------------------------------------------}
{
    Project         : SMTPEngine

    Module Authors  : Lanthan Astat (Astat)
                                                                               }
{------------------------------------------------------------------------------}
{                           Module Description                                 }
{------------------------------------------------------------------------------}
{
    Standalone native SMTP Engine.
                                                                               }
{------------------------------------------------------------------------------}
{                           Module History                                     }
{------------------------------------------------------------------------------}
{
   - Initial version 1.0 25.06.2003
   -         version 1.1 13.08.2003 Attachment Bug Fixed
   -         version 1.2 24.09.2003 socket close
   - Usage:
        ...
        uses
          Email in 'Email.pas';
        var
          smtp:TSMTPEngine;
          SendOk:boolean;
        begin
          smtp:=TSMTPEngine.Create(
            '10.73.22.23',                    // 'ESSXLC001.esa.local';  Server
            '[e-mail]',         // Recip,
            'this is the mail message text',  // Body,
            'MAIL_SERVICE',                   // From,
            '[e-mail]',         // Cc,
            'Betreff',                        // Subject,
            ''                                // ParamStr(0) Attachment
            );
          SendOk := smtp.SendEmail;
          smtp.free;
          ...                                                                  }
{------------------------------------------------------------------------------}
{                           End of Module Details                              }
{------------------------------------------------------------------------------}


unit Email;

interface

uses
  Windows, WinSock, SysUtils;

type
  TSMTPEngine = class   // socket and file access threadsave implemented
  private
    FSock    : TSocket;
    FFileBuf : AnsiString;
    FServerIP , FRecip, FBody, FFrom, FCc, FSubject, FAttachment: String;
    function  SendData(STR: string): Boolean;
    function  CheckRecv(const Code:string): Boolean;
    function  ExtractFileName(const FileName: ShortString): String;
    function Base64Encode(Input : String) : String;
    function CheckIPEx(s:string): Boolean;
    function GetIPFromHost(const HostName: string): string;
    function FileExists(const FileName: string): Boolean;
  public
    constructor Create(const server, Recip, Body, From, Cc, Subject, Attachment: String);
    destructor Destroy; Override;
    function  SendEmail : Boolean;
  end;

implementation

type
  TLookup = array [0..64] of Char;

const
  Base64Out: TLookup =
    (
    'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M',
    'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z',
    'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm',
    'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z',
    '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '+', '/', '='
   );

var
  _SocketLock: TRTLCriticalSection;

function TSMTPEngine.FileExists(const FileName: string): Boolean;
begin
  Result := FileAge(FileName) <> -1;
end;

function TSMTPEngine.SendData(STR: string) : Boolean;
var
  cbSent: integer;
begin
  EnterCriticalSection(_SocketLock);
  try
    cbSent := Send(FSock, STR[1], Length(STR), 0);
    if ((cbSent <> SOCKET_ERROR) and (cbSent = Length(STR))) then Result := True
      else Result := False;
  finally
    LeaveCriticalSection(_SocketLock);
  end;
end;

function TSMTPEngine.ExtractFileName(const FileName: ShortString): String;
var
  I: Integer;
begin
  I := Length(FileName);
  while (I >= 1) and not(FileName[I] in ['\', ':']) do Dec(I);
  Result := Copy(FileName, I + 1, 255);
end;

function TSMTPEngine.CheckRecv(const Code: string): Boolean;
var
  Buf : array [0..4096] of Char;
begin
  ZeroMemory(@Buf[0], SizeOf(Buf));
  EnterCriticalSection(_SocketLock);
  try
    if (Recv(FSock, Buf, SizeOf(Buf), 0) = SOCKET_ERROR) or (Copy(Buf, 1, 3) <> Code) then
      Result := False else Result := True;
  finally
    LeaveCriticalSection(_SocketLock);
  end;
  {$IFDEF ConsoleDebug}
    Write(Buf);
  {$ENDIF}
end;

function TSMTPEngine.Base64Encode(Input : String) : String;
var
  Final : String;
  Count : Integer;
  Len   : Integer;
begin
  Final := '';
  Count := 1;
  Len   := Length(Input);
  while Count <= Len do begin
    Final := Final + Base64Out[(Byte(Input[Count]) and $FC) shr 2];
    if (Count + 1) <= Len then begin
      Final := Final + Base64Out[((Byte(Input[Count]) and $03) shl 4) +
                                 ((Byte(Input[Count+1]) and $F0) shr 4)];
      if (Count+2) <= Len then begin
          Final := Final + Base64Out[((Byte(Input[Count+1]) and $0F) shl 2) +
                                     ((Byte(Input[Count+2]) and $C0) shr 6)];
          Final := Final + Base64Out[(Byte(Input[Count+2]) and $3F)];
      end
      else begin
          Final := Final + Base64Out[(Byte(Input[Count+1]) and $0F) shl 2];
          Final := Final + '=';
      end
    end
    else begin
      Final := Final + Base64Out[(Byte(Input[Count]) and $03) shl 4];
      Final := Final + '==';
    end;
    Count := Count + 3;
  end;
  Result := Final;
end;


function TSMTPEngine.SendEmail: Boolean;
var
  F          : file;
  WSAData    : TWSAData;
  P          : AnsiString;
  SockAddrIn : TSockAddrIn;
  LocalHost  : array [0..63] of CHAR;
begin
  Result := False;
  {$IFDEF ConsoleDebug}
    Writeln('Send mail:'#13#10);
  {$ENDIF}
  WSAStartUp(257, WSAData);
  try
    GetHostName(LocalHost, SizeOf(LocalHost));
    FSock := Socket(AF_INET, SOCK_STREAM, IPPROTO_IP);
    SockAddrIn.sin_family := AF_INET;
    SockAddrIn.sin_port := htons(25);
    SockAddrIn.sin_addr.S_addr := inet_addr(pChar(FServerIP)); // allways us ip
    Connect(FSock, SockAddrIn, SizeOf(SockAddrIn));
    if not CheckRecv('220') then EXIT;
    if not SendData('HELO ' + LocalHost + #13#10)then EXIT;
    if not CheckRecv('250') then EXIT;
    if not SendData('MAIL FROM: <' + FFrom + '>'#13#10)then EXIT;
    if not CheckRecv('250') then EXIT;
    if not SendData('RCPT TO: <' + FRecip + '>'#13#10)then EXIT;
    if not CheckRecv('250') then EXIT;
    if not SendData('DATA'#13#10)then EXIT;
    if not CheckRecv('354') then EXIT;
    if FileExists(FAttachment) then begin  // with attachment
      if not SendData(
        'From: '    + FFrom    + #13#10 +
        'To: '      + FRecip   + #13#10 +
        'Cc: '      + FCc      + #13#10 +
        'Subject: ' + FSubject + #13#10 +
        'MIME-Version: 1.0'#13#10 +
        'Content-type: multipart/mixed; boundary="bla"'#13#10#13#10 +
        '--bla'#13#10 +
        'Content-type: text/plain; charset:us-ascii'#13#10#13#10 +
        FBody + #13#10#13#10 +
        '--bla'+#13#10 +
        'Content-type: application/x-shockwave-flash;'#13#10 +
        '    name="' + ExtractFileName(FAttachment) + '"'#13#10 +
        'Content-Transfer-Encoding: base64'#13#10#13#10
        )
      then EXIT;

      EnterCriticalSection(_SocketLock);
      try
        AssignFile(F, FAttachment);
        FileMode := 0;
        try
          Reset(F, 1);
          if IOResult = 0 then begin
            SetLength(FFileBuf, FileSize(F));
            BlockRead(F, FFileBuf[1], FileSize(F));
            p := Base64Encode(FFileBuf);
            if not SendData(P)then EXIT;
            CloseFile(F);
          end;
        except
          EXIT;
        end;
      finally
        LeaveCriticalSection(_SocketLock);
      end;
    end else begin // without attachment
      if not SendData(
        'From: '    + FFrom    + #13#10 +
        'To: '      + FRecip   + #13#10+
        'Cc: '      + FCc      + #13#10+
        'Subject: ' + FSubject + #13#10 +
        'MIME-Version: 1.0'#13#10 +
        'Content-type: multipart/mixed; boundary="bla"'#13#10#13#10 +
        '--bla'#13#10 +
        'Content-type: text/plain; charset:us-ascii'#13#10#13#10 +
        FBody + #13#10#13#10
        )
      then EXIT;
    end;
    if not SendData(#13#10'--bla--'#13#10'.'#13#10) then EXIT;
    if not CheckRecv('250') then EXIT;
    if not SendData('QUIT'#13#10) then EXIT;
    closesocket(FSock);
    Result := True;
  finally
    WSACleanup();
  end;
end;

// This function is optimized for speed
function TSMTPEngine.CheckIPEx(s: string): Boolean;
var
  s1, s2, s3, s4: String;
  e, v, i, j: Integer;
  bcLen: integer;
  ix: array[1..3] of integer;
begin
  result := false;
  j := 0;
  bcLen := Length(s);
  for i:= 1 to bcLen do begin
      if s[i]= '.' then begin
         inc(j);
         ix[j] := i;
      end;
  end;
  if j <> 3 then EXIT;
  s1 := copy(s, 1, ix[1] - 1);
  s2 := copy(s, ix[1] + 1, ix[2] - ix[1] - 1);
  s3 := copy(s, ix[2] + 1, ix[3] - ix[2] - 1);
  s4 := copy(s, ix[3] + 1, bcLen);
  Val(s1, v, e);
  if (e <> 0) or (v > 255) or (v < 0) or ((Length(s1) > 1) and (s1[1] = '0')) then EXIT;
  Val(s2, v, e);
  if (e <> 0) or (v > 255) or (v < 0) or ((Length(s2) > 1) and (s2[1] = '0')) then EXIT;
  Val(s3, v, e);
  if (e <> 0) or (v > 255) or (v < 0) or ((Length(s3) > 1) and (s3[1] = '0')) then EXIT;
  Val(s4, v, e);
  if (e <> 0) or (v > 255) or (v < 0) or ((Length(s4) > 1) and (s4[1] = '0')) then EXIT;
  result := true;
end;

function TSMTPEngine.GetIPFromHost(const HostName: string): string;
type
  TaPInAddr = array[0..10] of PInAddr;
  PaPInAddr = ^TaPInAddr;
var
  phe: PHostEnt;
  pptr: PaPInAddr;
  i: Integer;
  GInitData: TWSAData;
begin
  WSAStartup($101, GInitData);
  Result := '';
  phe := GetHostByName(PChar(HostName));
  if phe = nil then Exit;
  pPtr := PaPInAddr(phe^.h_addr_list);
  i := 0;
  while pPtr^[i] <> nil do
  begin
    Result := inet_ntoa(pptr^[i]^);
    Inc(i);
  end;
  WSACleanup;
end;

constructor TSMTPEngine.Create(const Server, Recip, Body, From, Cc, Subject, Attachment : String);
begin
  inherited create;

  if not CheckIPEx(Server) then begin
    FServerIP := GetIPFromHost(Server);
  end else
    FServerIP := Server;

  FRecip := Recip;
  FBody := Body;
  FFrom := From;
  FCc := Cc;
  FSubject := Subject;
  FAttachment := Attachment;

end;

destructor TSMTPEngine.Destroy;
begin
  inherited;
end;

initialization
  InitializeCriticalSection(_SocketLock);
finalization
  DeleteCriticalSection(_SocketLock);
end.

[idefix2]

Ich habe diese Routine jetzt gründlich überarbeitet.
Danke an alle, die mir Hinweise dafür gegeben haben. Das Programm ist jetzt mit den neuen Delphi-Versionen kompatibel (die obige Version war noch für 8-bit-Characters geschrieben) und kann jetzt SMTP-Login sowie beliebig viele Attachments verabeiten.

Um SMTP-Login zu aktivieren, genügt es, nach dem Create und vor dem Sendmail die Properties "user" und "Password" zu setzen.


Edit:
Jetzt habe ich die richtige Email.pas hochgeladen.
In der vorigen war Mailversand nur mit SMTP-Login möglich.