1:
2:
3:

ShellExecute(Application.Handle, 'open',

PChar('mailto:name@domain.de?subject=Betreff&body=irgendein Text'), nil, nil, sw_ShowNormal);                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:

unit csEMailer;

interface
uses Classes;

Type
  TEMailClientClass = Class Of TAbstractEMailClient;

  TAbstractEMailClient = Class
  Private
    fSubject: String;
    fAttachments: TStringList;
    fBody: TStringList;
    fRecipients: TStringList;
    Function RecipientList: String;
  Public
    Constructor Create;
    Destructor Destroy; Override;
    Property Recipients : TStringList Read fRecipients;
    Property Body : TStringList Read fBody;
    Property Subject : String Read fSubject Write fSubject;
    Property Attachments : TStringList Read fAttachments;
    Function CanSend : Boolean; Virtual;
    Procedure Clear;
    Procedure Send; Virtual; Abstract;
    End;

  TGenericEmailClient = Class (TAbstractEMailClient)
  Public
    Function CanSend : Boolean; Override;
    Procedure Send; Override;
    End;

  TOutlookEmailClient = Class (TAbstractEMailClient)
  Public
    Procedure Send; Override;
    End;

  TLotusEMailClient = Class (TAbstractEMailClient)
  Public
    Procedure Send; Override;
    End;

Function CreateEMailObject : TAbstractEMailClient;

implementation
Uses Windows, Forms, SysUtils, Shellapi, ComObj, OutlookTools, Variants;
{ TAbstractEMailClient }

Function CreateEMailObject : TAbstractEMailClient;
  Function LotusInstalled : Boolean;
  Var
    aLotusSession : Variant;

  Begin
    Try
      aLotusSession :=  CreateOleObject('Notes.NotesSession');
      aLotusSession := Unassigned;
      Result := True;
    Except
      Result := False;
      End
  End;

  Function OutlookInstalled : Boolean;
  Var
    o : TOutlookconnect;

  Begin
    o := TOutlookConnect.Create (Nil);
    Try
      o.Connected := True;
      Result := True;
    Except
      Result := False;
      End;
    o.Free
  End;

Begin
  If LotusInstalled Then
    Result := TLotusEmailClient.Create
  Else If OutLookInstalled then
    Result := TOutlookEmailClient.Create
  Else
    Result := TGenericEmailClient.Create
End;

function TAbstractEMailClient.CanSend: Boolean;
begin
  Result := (fSubject<>'') And (fRecipients.count > 0);
end;

procedure TAbstractEMailClient.Clear;
begin
  fSubject := '';
  fAttachments.Clear;
  fBody.Clear;
  fRecipients.Clear;
end;

constructor TAbstractEMailClient.Create;
begin
  Inherited Create;
  fAttachments := TStringlist.Create;
  fBody := TStringlist.Create;
  fRecipients := TStringlist.Create;
  Clear;
end;

destructor TAbstractEMailClient.Destroy;
begin
  fAttachments.Free;
  fBody.Free;
  fRecipients.Free;
  inherited;
end;

Function TAbstractEMailClient.RecipientList : String;
Var
  i : Integer;

Begin
  Result := '';
  For i:=0 To fRecipients.count - 1 do
    If Result = '' Then
      Result := fRecipients[i]
    else
      Result := Result +';'+fRecipients[i]
End;

function TGenericEmailClient.CanSend: Boolean;
begin
  Result := Inherited CanSend and (fAttachments.Count <= 1);
end;

Function Escaped (Const s : String) : String;
Var
  i : Integer;

Begin
  Result := '';
  For i:=1 To length (s) do
    If ord (s[i]) in [33..127] then
      Result := Result+s[i]
    Else
      Result := Result+'%'+IntToHex (Ord(s[i]),2);
End;

Procedure TGenericEMailClient.Send;
Var
s : TStringlist;

  aMailto : String;

  Function _BodyList : String;
  Var
    i : Integer;

  Begin
    Result := '&body=';
    For i:=0 To fBody.Count-1 do
      Result := Result+Escaped (fBody[i])+'%0D%0A';
  End;

  Function _Attachmentlist : String;
  Var
    i : Integer;

  Begin
    Case fAttachments.count Of
      0 : Result := '';
      1 : Result := '&attach="'+fAttachments[0]+'"';
      Else
        Raise Exception.Create('Generic mailto does not support more than one file attachment');
      End
  End;

  Function _Subject : String;
  Begin
    Result := Escaped(fSubject) 
  End;

Begin
  aMailTo := 'mailto:'+RecipientList+'?subject='+_Subject+_BodyList+_AttachmentList;
s:=TStringlist.create; s.add (amailto); s.savetofile('c:\mail.txt'); s.free;
  ShellExecute(Application.Handle, 'OPEN', PChar(aMailTo), nil, nil, SW_SHOWDEFAULT);
End;

Procedure TOutlookEmailClient.Send;
Var
  MyMail : Variant;
  O : ToutlookConnect;
  i : Integer;

Begin
  O := TOutlookConnect.Create(Nil);
  Try
    O.Connected := True;
    MyMail:=o.CreateMail(O.CurrentUser);
    MyMail.To := fRecipients[0];
    MyMail.Body := fBody.Text;
    MyMail.Subject := fSubject;
    For i:=1 to fRecipients.count - 1 do
      O.AddRecipientToMail(MyMail, fRecipients[i]);
    For i:=0 To fAttachments.Count - 1 do
      o.AddAttachmentToMail(MyMail, fAttachments[i]);
    MyMail.send;
  Finally
    o.free;
    End;
End;

{ TLotusEMailClient }

procedure TLotusEMailClient.Send;
Var
  UserName, MailDbName : String;
  Maildb, MailDoc, MailBody, Session : Variant;
  p : Integer;
  aRecipients : Variant;

Begin
  aRecipients := VarArrayCreate ([1,fRecipients.count], varString);
  For p := 0 to fREcipients.count - 1 do aRecipients[p+1] := aRecipients[p];
  Session := CreateOleObject('Notes.NotesSession');
  UserName := Session.UserName;
  MailDbName := Copy (UserName,1,1) +  Copy (UserName, Pos (' ',UserName)+1, Length(UserName)) +'.nsf';
  Maildb := Session.GETDATABASE('', MailDbName);
  If Maildb.ISOPEN = True Then
  Else
    Maildb.OPENMAIL;
  MailDoc := Maildb.CREATEDOCUMENT;
  MailDoc.Form := 'Memo';
  MailDoc.Sendto := aRecipients;
  MailDoc.Subject := fSubject;
  MailDoc.SAVEMESSAGEONSEND := True;
  MailBody := MailDoc.CreateRichTextItem('body');
  For p := 0 to fBody.Count - 1 do
    MailBody.AppendText(fBody[p]);
  MailBody.AddNewLine(2);
  for p:= 0 to fAttachments.count - 1 do
    MailBody.EmbedObject(1454, '', fAttachments[p], 'Attachment');

  MailDoc.PostedDate := Now;
  MailDoc.SEND (0, aRecipients);
  Maildb := Unassigned;
  MailDoc := Unassigned;
  MailBody := Unassigned;
  Session := Unassigned;
End;
end.                    

1:

ShellExecute(0, 'open', PChar('mailto:?Attach=""D:\temp\testDOKUMENT.doc""'), nil, nil, SW_SHOW);