Indy E-Mail senden innerhalb eines Threads (Komponente)

[psycodad]

Unit zum Senden eines E-Mails innerhalb eines Threads. Das heisst, der Programmablauf geht weiter während parallel ein E-Mail versendet werden kann.
Die Komponente kann selbstverständlich eigenen Bedürfnissen angepasst werden. Bin froh um jede Anregung und Kritik.

Beispiel zur Verwendung der Komponente:

Delphi-Quellcode:

procedure TForm1.DoSendEMail;
var
  Mail: TSendEMail;
begin
  Mail := TSendEMail.Create;
  Mail.OnBegin := OnBeginEMail;
  Mail.OnFinish := OnFinishEMail;
  Mail.Resume;
end;


Procedure TForm1.OnBeginEMail(Sender: TObject);
begin
  with sender as TSendEMail do begin
    Empfaenger.Add('Hans Muster=[e-mail]');
    AbsenderName := 'Absender';
    AbsenderEMail := '[e-mail]';
    Betreff := 'Betreff';
    Nachricht.Add('1. Zeile');
    Nachricht.Add('2. Zeile');
    if fileexists('c:\test.log') then Attachements.Add('c:\test.log');
  end;
end;

procedure TForm1.OnFinishEMail(ErrMsg: string);
begin
  if ErrMsg > ''  then begin
    //Fehlermeldung ausgeben, Log schreiben etc..
  end;

end;

Die Unit:

Delphi-Quellcode:

unit EMailU;

interface

uses
  Windows, classes, SysUtils, variants,
  ShellAPI, SpecialFoldersU, VersionInfoU, SpezFunctionsU,
  IdBaseComponent, IdComponent, IdTCPConnection,
  IdTCPClient, IdSMTP, idMessage, idEMailAddress, idAttachmentFile;

type
  TMyFinishEvent = procedure(ErrMsg: string) of object;
  TMyBeginEvent = procedure(Sender: TObject) of object;
  TSendEMail = class(TThread)
  private
    FEmpfaenger: TStringList;
    FBCCEmpfaenger: TStringList;
    FAttachements: TStringList;
    FAbsenderName: String;
    FAbsenderEMail: String;
    FReplayToEMail: String;
    FBetreff: string;
    FNachricht: TStringlist;

    FOnFinish : TMyFinishEvent;
    FOnBegin : TMyBeginEvent;
    FIdSMTP: TIdSMTP;
    procedure SetName;
    function SendMail: string;
  protected
    procedure Execute; override;
    //constructor Create(CreateSuspended: Boolean);
  public
    Constructor Create();
    destructor Destroy; override;
  //Published
    { Published declarations }
      Property Empfaenger: TStringlist read FEmpfaenger write FEmpfaenger;
      Property BCCEmpfaenger: TStringlist read FBCCEmpfaenger write FBCCEmpfaenger;
      Property Attachements: TStringlist read FAttachements write FAttachements;
      Property AbsenderName: String read FAbsenderName write FAbsenderName;
      Property AbsenderEMail: String read FAbsenderEMail write FAbsenderEMail;
      Property ReplayToEMail: String read FReplayToEMail write FReplayToEMail;
      Property Betreff: String read FBetreff write FBetreff;
      Property Nachricht: TStringlist read FNachricht write FNachricht;
      property OnFinish : TMyFinishEvent read FOnFinish write FOnFinish;
      property OnBegin : TMyBeginEvent read FOnBegin write FOnBegin;
  end;

implementation

{ Wichtig: Methoden und Eigenschaften von Objekten in visuellen Komponenten dürfen
  nur in einer Methode namens Synchronize aufgerufen werden, z.B.

      Synchronize(UpdateCaption);

  und UpdateCaption könnte folgendermaßen aussehen:

    procedure TUpdate.UpdateCaption;
    begin
      Form1.Caption := 'Aktualisiert in einem Thread';
    end; }

{$IFDEF MSWINDOWS}
type
  TThreadNameInfo = record
    FType: LongWord;     // muss 0x1000 sein
    FName: PChar;        // Zeiger auf Name (in Anwender-Adress-Bereich)
    FThreadID: LongWord; // Thread-ID (-1 ist Caller-Thread)
    FFlags: LongWord;    // reserviert für zukünftige Verwendung, muss 0 sein
  end;
{$ENDIF}


constructor TSendEMail.Create();
begin
  inherited Create(True); //CreateSuspendend
  Priority := tpLower;
  FreeOnTerminate := true;

  FEmpfaenger := TStringlist.Create;
  FBCCEmpfaenger := TStringlist.Create;
  FAttachements := TStringlist.Create;
  FNachricht := TStringlist.Create;
  FIdSMTP := TidSMTP.Create(nil);

end;

Destructor TSendEMail.Destroy;
begin
  FidSMTP.Free;
  FEmpfaenger.free;
  FBCCEmpfaenger.free;
  FAttachements.free;
  FNachricht.free;
  inherited Destroy;
end;


procedure TSendEMail.SetName;
{$IFDEF MSWINDOWS}
var
  ThreadNameInfo: TThreadNameInfo;
{$ENDIF}
begin
{$IFDEF MSWINDOWS}
  ThreadNameInfo.FType := $1000;
  ThreadNameInfo.FName := 'TSendEMail';
  ThreadNameInfo.FThreadID := $FFFFFFFF;
  ThreadNameInfo.FFlags := 0;

  try
    RaiseException( $406D1388, 0, sizeof(ThreadNameInfo) div sizeof(LongWord), @ThreadNameInfo );
  except
  end;
{$ENDIF}
end;

procedure TSendEMail.Execute;
var
  ErrMsg: string;
begin
  SetName;

  if self.Terminated then exit;

  { Thread-Code hier einfügen }

  //OnBegin-Ereignsi auslösen
  if assigned(FOnBegin) then
    FOnBegin(self);

  //Checks
  if not assigned(FEmpfaenger) then
    ErrMsg := 'Kein(e) Empfaenger!'
  else
    if FEmpfaenger.Count = 0 then ErrMsg := 'Kein(e) Empfaenger!';

  if FAbsenderEMail = '' then ErrMsg := 'Kein Absender E-Mail';
  if FReplayToEmail = '' then FReplayToEmail := FAbsenderEMail;


  //Mail versenden
  if ErrMsg = '' then ErrMsg := SendMail;

  // Finish-Erreignis auslösen
  if assigned(FOnFinish) then
    FOnFinish(ErrMsg);
end;

function TSendEMail.SendMail;
var
  Msg: TidMessage;
  Adr: TidEMailAddressItem;
  i: integer;
begin
  Result := '';
  try
    FidSMTP.Host        := 'mailserver.xxx.ch';
    FidSMTP.Port        := 587;
    FidSMTP.UserName    := 'xxx';
    Fidsmtp.Password    := 'xxx';
    if FidSMTP.Connected then Fidsmtp.Disconnect;
    Fidsmtp.Connect;
    Fidsmtp.AuthType := atDefault;
    if Fidsmtp.Authenticate then begin

      //Nachricht erstellen
      Msg := TidMessage.Create();
      try
        if assigned(FAttachements) then
          if FAttachements.Count > 0 then
            msg.ContentType :='multipart/mixed'
          else
            msg.ContentType :='text/plain';

        Msg.From.Name := FAbsenderName;
        Msg.From.Address := FAbsenderEMail;
        Msg.Body.Text := FNachricht.text ;
        Msg.Subject := FBetreff;
        Msg.Date := date;
        Msg.Organization := 'Plotjet Administration';

        //Empfaenger zuweisen
        if assigned(FEmpfaenger) then begin
          for i:=0 to FEmpfaenger.count -1 do begin
            Adr := Msg.Recipients.Add;
            Adr.Name := FEmpfaenger.Names[i];
            Adr.Address := FEmpfaenger.ValueFromIndex[i];
          end;
        end;

        //BCC zuweisen
        if assigned(FBCCEmpfaenger) then begin
          for i:=0 to FBCCEmpfaenger.count -1 do begin
            Adr := Msg.BccList.Add;
            Adr.Name := FBCCEmpfaenger.Names[i];
            Adr.Address := FBCCEmpfaenger.ValueFromIndex[i];
          end;
        end;

        //Replay to zuweisen
        if FReplayToEmail > '' then begin
          adr := msg.ReplyTo.Add;
          adr.Name := FReplayToEmail;
          adr.Address := FReplayToEmail;
        end;

        //Anhang erstellen
        if assigned(FAttachements) then begin
          for i := 0 to FAttachements.Count - 1 do begin
             TidAttachmentFile.Create(msg.MessageParts,FAttachements[i]);
          end;
        end;

        try
          fidSMTP.Send(msg);
          Fidsmtp.Disconnect;
        except
          on e: exception do Result := e.Message;
        end;

      finally
        msg.Free;
      end;
    end else begin
      Result := 'Authentifizierung an Mail-Server: ' + FidSMTP.Host + ' fehlgeschlagen!';
    end;
  except
    On e: exception do Result := e.Message;
  end;

end;


end.

Ich hoffe, dass ich jemandem helfen konnte..