-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathsmtpclientlib.pas
286 lines (260 loc) · 9.94 KB
/
smtpclientlib.pas
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
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
unit smtpclientlib;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fileutil,
smtpsend, mimemess, mimepart, synautil;
{
Based on Ararat Synapse library 0.40, by Lukas Gebauer (http://synapse.ararat.cz/)
Ararat Synapse is a non-visual internet library
This unit extends the Synapse TSmtpSend object to make it easier to use
Sample usage:
procedure TForm1.ButtonClick(Sender: TObject);
var
oSmtpClient: TSmtpClient;
begin
oSmtpClient := TSmtpClient.Create;
try
oSmtpClient.ServerDomain := 'smtp.mandrillapp.com';
oSmtpClient.ServerPort := '587';
oSmtpClient.ServerLoginUsername := '[email protected]';
oSmtpClient.ServerLoginPassword := 'difficult-and-long-password';
oSmtpClient.MessageClear;
oSmtpClient.BodyAsPlainText.Text := 'Plain body text.';
oSmtpClient.BodyAsHtml.Text := '<html><head></head><body><h2>Html body text.</h2><img src="C:\lazarus\examples\jpeg\lazarus.jpg" /></body></html>';
oSmtpClient.AddInlineAttachment( 'C:\lazarus\examples\jpeg\lazarus.jpg' );
oSmtpClient.AddAttachment( ExtractFilePath( ParamStr( 0 ) ) + 'project1.lpi' );
if oSmtpClient.Send( '[email protected]', '[email protected]', '', '', 'Buy more of our stuff' ) then
ShowMessage( 'Send ok' )
else
ShowMessage( oSmtpClient.SendResult );
finally
oSmtpClient.Free;
end;
end;
More docs and code:
http://synapse.ararat.cz/doc/help/smtpsend.TSMTPSend.html
http://stackoverflow.com/questions/15604243/how-to-send-a-e-mail-for-more-than-one-recipient-at-once-using-delphi-and-synap
http://synapse.ararat.cz/doku.php/public:howto:sendingbcc
http://synapse.ararat.cz/doku.php/public:howto:smtpsend = with TLS
http://coding.derkeiler.com/Archive/Delphi/borland.public.delphi.thirdpartytools.general/2006-07/msg00249.html = attachments
http://en.wikipedia.org/wiki/Simple_Mail_Transfer_Protocol
}
type
{ TSmtpClient }
TSmtpClient = class( TSmtpSend )
private
// create parts also at object creation
// could wait until actual Send(), but then no user customization would be possible for headers
MessageParts: TMimeMess;
Attachments: TStringList;
FBodyAsHtml: TStringList;
FBodyAsPlainText: TStringList;
FSendResult: string;
FServerAddress: string;
FServerLoginPassword: string;
FServerLoginUsername: string;
FServerPort: string;
procedure SetSendResult(AValue: string);
procedure SetServerAddress(AValue: string);
procedure SetServerLoginPassword(AValue: string);
procedure SetServerLoginUsername(AValue: string);
procedure SetServerPort(AValue: string);
procedure SendResultClear;
procedure SendResultAppend( sText: string );
public
// server related stuff - set once
property ServerAddress: string read FServerAddress write SetServerAddress;
property ServerPort: string read FServerPort write SetServerPort;
property ServerLoginUsername: string read FServerLoginUsername write SetServerLoginUsername;
Property ServerLoginPassword: string read FServerLoginPassword write SetServerLoginPassword;
// messsage parts - set for each message
// if there is both a plain text and html body, then normally all receiving software shows the html version only
property BodyAsPlainText: TStringList read FBodyAsPlainText;
property BodyAsHtml: TStringList read FBodyAsHtml;
// save all replies from server
property SendResult: string read FSendResult write SetSendResult;
constructor Create;
destructor Destroy; override;
procedure MessageClear;
function AddInlineAttachment( sFile: string; sContentID: string = ''; bReplaceInBodyHtml: Boolean = True ): Boolean;
function AddAttachment( sFile: string ): Boolean;
function Send( sFrom, sToList, sCCList, sBCCList, sSubject: string ): Boolean;
{
Other usefull methods of TSmtpSend:
Self.SystemName
Headers.CustomHeaders -> http://synapse.ararat.cz/doc/help/mimemess.TMessHeader.html#CustomHeaders
Headers.Organization
Headers.ReplyTo
}
end;
implementation
{ TSmtpClient }
procedure TSmtpClient.SetServerAddress(AValue: string);
begin
if FServerAddress = AValue then
Exit;
FServerAddress := AValue;
TargetHost := AValue;
end;
procedure TSmtpClient.SetSendResult(AValue: string);
begin
if FSendResult = AValue then
Exit;
FSendResult := AValue;
end;
procedure TSmtpClient.SetServerLoginPassword(AValue: string);
begin
if FServerLoginPassword = AValue then
Exit;
FServerLoginPassword := AValue;
Password := AValue;
end;
procedure TSmtpClient.SetServerLoginUsername(AValue: string);
begin
if FServerLoginUsername = AValue then
Exit;
FServerLoginUsername := AValue;
UserName := AValue;
end;
procedure TSmtpClient.SetServerPort(AValue: string);
begin
if FServerPort = AValue then
Exit;
FServerPort := AValue;
TargetPort := AValue;
end;
procedure TSmtpClient.SendResultClear;
begin
SendResult := '';
end;
procedure TSmtpClient.SendResultAppend(sText: string);
begin
SendResult := SendResult + sText + #13#10;
end;
constructor TSmtpClient.Create;
begin
inherited Create;
MessageParts := TMimeMess.Create;
Attachments := TStringList.Create;
FBodyAsPlainText := TStringList.Create;
FBodyAsHtml := TStringList.Create;
end;
destructor TSmtpClient.Destroy;
begin
MessageParts.Free;
Attachments.Free;
FBodyAsPlainText.Free;
FBodyAsHtml.Free;
inherited Destroy;
end;
procedure TSmtpClient.MessageClear;
begin
MessageParts.Clear;
Attachments.Clear;
BodyAsPlainText.Clear;
BodyAsHtml.Clear;
end;
function TSmtpClient.AddInlineAttachment(sFile: string; sContentID: string = ''; bReplaceInBodyHtml: Boolean = True ): Boolean;
var
s: string;
i: Integer;
begin
Result := FileExists( sFile );
if Result then begin
if sContentID = '' then
sContentID := ExtractFileNameWithoutExt( ExtractFileName( sFile ) );
if bReplaceInBodyHtml then begin
s := LowerCase( ' src="' + sFile + '"' );
i := Pos( s, LowerCase( BodyAsHtml.Text ) );
if i = 0 then begin
StringReplace( s, '"', '''', [ rfReplaceAll ] );
i := Pos( s, LowerCase( BodyAsHtml.Text ) );
end;
if i > 0 then
BodyAsHtml.Text := StringReplace( BodyAsHtml.Text, s, 'src="cid:' + sContentID + '"', [rfReplaceAll, rfIgnoreCase] );
end;
// save info; actual appending happens as Send()
Attachments.Append( sContentID + '=' + sFile );
end;
end;
function TSmtpClient.AddAttachment(sFile: string): Boolean;
begin
Result := FileExists( sFile );
// save info; actual appending happens as Send()
if Result then
Attachments.Append( sFile );
end;
function TSmtpClient.Send(sFrom, sToList, sCCList, sBCCList, sSubject: string): Boolean;
var
sList, sAddress: string;
MultiPartMix, MultiPartRel, MultiPartAlt: TMimePart;
i: Integer;
begin
Result := False;
SendResultClear;
// construct message headers
MessageParts.Header.From := sFrom;
// CommaText := sToList would be logical, but that also breaks at spaces
sList := sToList;
repeat
sAddress := Trim( FetchEx( sList, ',', '"' ) );
if ( sAddress <> '' ) then
MessageParts.Header.ToList.Append( sAddress );
until sList = '';
sList := sCCList;
repeat
sAddress := Trim( FetchEx( sList, ',', '"' ) );
if ( sAddress <> '' ) then
MessageParts.Header.CCList.Append( sAddress );
until sList = '';
MessageParts.Header.Subject := sSubject;
MessageParts.Header.Date := Now;
MessageParts.Header.XMailer := 'Synapse ' + ExtractFileNameWithoutExt( ExtractFileNameOnly( ParamStr( 0 ) ) ); // defaults to synapse developer
// add body and other parts
// multiparts (parent-parts)
MultiPartMix := MessageParts.AddPartMultipart( 'mixed', nil );
MultiPartRel := MessageParts.AddPartMultipart( 'related', MultiPartMix );
MultiPartAlt := MessageParts.AddPartMultipart( 'alternative', MultiPartRel );
if BodyAsPlainText.Count > 0 then
MessageParts.AddPartText( BodyAsPlainText, MultiPartAlt );
if BodyAsHtml.Count > 0 then
MessageParts.AddPartHTML( BodyAsHtml, MultiPartAlt );
for i := 0 to Attachments.Count - 1 do begin
if Attachments.Names[ i ] = '' then
// no name means no name=value, so this is an unrelated file
MessageParts.AddPartBinaryFromFile( Attachments[ i ],
MultiPartMix )
else
// there is a name=value, so this is htmlbody-related file
MessageParts.AddPartHTMLBinaryFromFile( Attachments.ValueFromIndex[ i ],
Attachments.Names[ i ],
MultiPartRel );
end;
// message is ready
MessageParts.EncodeMessage;
if Login then begin
SendResultAppend( 'Login: ' + FullResult.Text );
// inform server who is sending: send 'MAIL FROM:' command - use only the emailaddress (skip name)
MailFrom( GetEmailAddr( sFrom ), Length( MessageParts.Lines.Text ) );
SendResultAppend( 'Mail from ' + GetEmailAddr( sFrom ) + ': ' + FullResult.Text );
// inform server where this has to go: send 'RCPT TO:' command (more receivers, means more of this command)
sList := sToList + ',' + sCCList + ',' + sBCCList;
repeat
sAddress := GetEmailAddr( Trim( FetchEx( sList, ',', '"') ) );
if ( sAddress <> '' ) then begin
Result := MailTo( sAddress );
SendResultAppend( 'Mail to ' + sAddress + ': ' + FullResult.Text );
end;
until sList = '';
// send the message
if MailData( MessageParts.Lines ) then
Result := True;
SendResultAppend( 'Send: ' + FullResult.Text );
Logout;
SendResultAppend( 'Logout: ' + FullResult.Text );
end
else
SendResultAppend( 'Login: ' + FullResult.Text );
end;
end.