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.