source: trunk/Packages/synapse/mimemess.pas

Last change on this file was 5, checked in by chronos, 13 years ago
  • Added: Required packages.
File size: 27.1 KB
Line 
1{==============================================================================|
2| Project : Ararat Synapse | 002.005.002 |
3|==============================================================================|
4| Content: MIME message object |
5|==============================================================================|
6| Copyright (c)1999-2006, Lukas Gebauer |
7| All rights reserved. |
8| |
9| Redistribution and use in source and binary forms, with or without |
10| modification, are permitted provided that the following conditions are met: |
11| |
12| Redistributions of source code must retain the above copyright notice, this |
13| list of conditions and the following disclaimer. |
14| |
15| Redistributions in binary form must reproduce the above copyright notice, |
16| this list of conditions and the following disclaimer in the documentation |
17| and/or other materials provided with the distribution. |
18| |
19| Neither the name of Lukas Gebauer nor the names of its contributors may |
20| be used to endorse or promote products derived from this software without |
21| specific prior written permission. |
22| |
23| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
24| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
25| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
26| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
27| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
28| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
29| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
30| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
31| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
32| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
33| DAMAGE. |
34|==============================================================================|
35| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
36| Portions created by Lukas Gebauer are Copyright (c)2000-2006. |
37| All Rights Reserved. |
38|==============================================================================|
39| Contributor(s): |
40|==============================================================================|
41| History: see HISTORY.HTM From distribution package |
42| (Found at URL: http://www.ararat.cz/synapse/) |
43|==============================================================================}
44
45{:@abstract(MIME message handling)
46Classes for easy handling with e-mail message.
47}
48
49{$IFDEF FPC}
50 {$MODE DELPHI}
51{$ENDIF}
52{$H+}
53
54unit mimemess;
55
56interface
57
58uses
59 Classes, SysUtils,
60 mimepart, synachar, synautil, mimeinln;
61
62type
63
64 {:Possible values for message priority}
65 TMessPriority = (MP_unknown, MP_low, MP_normal, MP_high);
66
67 {:@abstract(Object for basic e-mail header fields.)}
68 TMessHeader = class(TObject)
69 private
70 FFrom: string;
71 FToList: TStringList;
72 FCCList: TStringList;
73 FSubject: string;
74 FOrganization: string;
75 FCustomHeaders: TStringList;
76 FDate: TDateTime;
77 FXMailer: string;
78 FCharsetCode: TMimeChar;
79 FReplyTo: string;
80 FMessageID: string;
81 FPriority: TMessPriority;
82 Fpri: TMessPriority;
83 Fxpri: TMessPriority;
84 Fxmspri: TMessPriority;
85 protected
86 function ParsePriority(value: string): TMessPriority;
87 function DecodeHeader(value: string): boolean; virtual;
88 public
89 constructor Create; virtual;
90 destructor Destroy; override;
91
92 {:Clears all data fields.}
93 procedure Clear; virtual;
94
95 {Add headers from from this object to Value.}
96 procedure EncodeHeaders(const Value: TStrings); virtual;
97
98 {:Parse header from Value to this object.}
99 procedure DecodeHeaders(const Value: TStrings);
100
101 {:Try find specific header in CustomHeader. Search is case insensitive.
102 This is good for reading any non-parsed header.}
103 function FindHeader(Value: string): string;
104
105 {:Try find specific headers in CustomHeader. This metod is for repeatly used
106 headers like 'received' header, etc. Search is case insensitive.
107 This is good for reading ano non-parsed header.}
108 procedure FindHeaderList(Value: string; const HeaderList: TStrings);
109 published
110 {:Sender of message.}
111 property From: string read FFrom Write FFrom;
112
113 {:Stringlist with receivers of message. (one per line)}
114 property ToList: TStringList read FToList;
115
116 {:Stringlist with Carbon Copy receivers of message. (one per line)}
117 property CCList: TStringList read FCCList;
118
119 {:Subject of message.}
120 property Subject: string read FSubject Write FSubject;
121
122 {:Organization string.}
123 property Organization: string read FOrganization Write FOrganization;
124
125 {:After decoding contains all headers lines witch not have parsed to any
126 other structures in this object. It mean: this conatins all other headers
127 except:
128
129 X-MAILER, FROM, SUBJECT, ORGANIZATION, TO, CC, DATE, MIME-VERSION,
130 CONTENT-TYPE, CONTENT-DESCRIPTION, CONTENT-DISPOSITION, CONTENT-ID,
131 CONTENT-TRANSFER-ENCODING, REPLY-TO, MESSAGE-ID, X-MSMAIL-PRIORITY,
132 X-PRIORITY, PRIORITY
133
134 When you encode headers, all this lines is added as headers. Be carefull
135 for duplicites!}
136 property CustomHeaders: TStringList read FCustomHeaders;
137
138 {:Date and time of message.}
139 property Date: TDateTime read FDate Write FDate;
140
141 {:Mailer identification.}
142 property XMailer: string read FXMailer Write FXMailer;
143
144 {:Address for replies}
145 property ReplyTo: string read FReplyTo Write FReplyTo;
146
147 {:message indetifier}
148 property MessageID: string read FMessageID Write FMessageID;
149
150 {:message priority}
151 property Priority: TMessPriority read FPriority Write FPriority;
152
153 {:Specify base charset. By default is used system charset.}
154 property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode;
155 end;
156
157 TMessHeaderClass = class of TMessHeader;
158
159 {:@abstract(Object for handling of e-mail message.)}
160 TMimeMess = class(TObject)
161 private
162 FMessagePart: TMimePart;
163 FLines: TStringList;
164 FHeader: TMessHeader;
165 public
166 constructor Create;
167 {:create this object and assign your own descendant of @link(TMessHeader)
168 object to @link(header) property. So, you can create your own message
169 headers parser and use it by this object.}
170 constructor CreateAltHeaders(HeadClass: TMessHeaderClass);
171 destructor Destroy; override;
172
173 {:Reset component to default state.}
174 procedure Clear; virtual;
175
176 {:Add MIME part as subpart of PartParent. If you need set root MIME part,
177 then set as PartParent @NIL value. If you need set more then one subpart,
178 you must have PartParent of multipart type!}
179 function AddPart(const PartParent: TMimePart): TMimePart;
180
181 {:Add MIME part as subpart of PartParent. If you need set root MIME part,
182 then set as PartParent @NIL value. If you need set more then 1 subpart, you
183 must have PartParent of multipart type!
184
185 This part is marked as multipart with secondary MIME type specified by
186 MultipartType parameter. (typical value is 'mixed')
187
188 This part can be used as PartParent for another parts (include next
189 multipart). If you need only one part, then you not need Multipart part.}
190 function AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
191
192 {:Add MIME part as subpart of PartParent. If you need set root MIME part,
193 then set as PartParent @NIL value. If you need set more then 1 subpart, you
194 must have PartParent of multipart type!
195
196 After creation of part set type to text part and set all necessary
197 properties. Content of part is readed from value stringlist.}
198 function AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
199
200 {:Add MIME part as subpart of PartParent. If you need set root MIME part,
201 then set as PartParent @NIL value. If you need set more then 1 subpart, you
202 must have PartParent of multipart type!
203
204 After creation of part set type to text part and set all necessary
205 properties. Content of part is readed from value stringlist. You can select
206 your charset and your encoding type. If Raw is @true, then it not doing
207 charset conversion!}
208 function AddPartTextEx(const Value: TStrings; const PartParent: TMimePart;
209 PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart;
210
211 {:Add MIME part as subpart of PartParent. If you need set root MIME part,
212 then set as PartParent @NIL value. If you need set more then 1 subpart, you
213 must have PartParent of multipart type!
214
215 After creation of part set type to text part to HTML type and set all
216 necessary properties. Content of HTML part is readed from Value stringlist.}
217 function AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
218
219 {:Same as @link(AddPartText), but content is readed from file}
220 function AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
221
222 {:Same as @link(AddPartHTML), but content is readed from file}
223 function AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
224
225 {:Add MIME part as subpart of PartParent. If you need set root MIME part,
226 then set as PartParent @NIL value. If you need set more then 1 subpart,
227 you must have PartParent of multipart type!
228
229 After creation of part set type to binary and set all necessary properties.
230 MIME primary and secondary types defined automaticly by filename extension.
231 Content of binary part is readed from Stream. This binary part is encoded
232 as file attachment.}
233 function AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
234
235 {:Same as @link(AddPartBinary), but content is readed from file}
236 function AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
237
238 {:Add MIME part as subpart of PartParent. If you need set root MIME part,
239 then set as PartParent @NIL value. If you need set more then 1 subpart, you
240 must have PartParent of multipart type!
241
242 After creation of part set type to binary and set all necessary properties.
243 MIME primary and secondary types defined automaticly by filename extension.
244 Content of binary part is readed from Stream.
245
246 This binary part is encoded as inline data with given Conten ID (cid).
247 Content ID can be used as reference ID in HTML source in HTML part.}
248 function AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
249
250 {:Same as @link(AddPartHTMLBinary), but content is readed from file}
251 function AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
252
253 {:Add MIME part as subpart of PartParent. If you need set root MIME part,
254 then set as PartParent @NIL value. If you need set more then 1 subpart, you
255 must have PartParent of multipart type!
256
257 After creation of part set type to message and set all necessary properties.
258 MIME primary and secondary types are setted to 'message/rfc822'.
259 Content of raw RFC-822 message is readed from Stream.}
260 function AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart;
261
262 {:Same as @link(AddPartMess), but content is readed from file}
263 function AddPartMessFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
264
265 {:Compose message from @link(MessagePart) to @link(Lines). Headers from
266 @link(Header) object is added also.}
267 procedure EncodeMessage;
268
269 {:Decode message from @link(Lines) to @link(MessagePart). Massage headers
270 are parsed into @link(Header) object.}
271 procedure DecodeMessage;
272 published
273 {:@link(TMimePart) object with decoded MIME message. This object can handle
274 any number of nested @link(TMimePart) objects itself. It is used for handle
275 any tree of MIME subparts.}
276 property MessagePart: TMimePart read FMessagePart;
277
278 {:Raw MIME encoded message.}
279 property Lines: TStringList read FLines;
280
281 {:Object for e-mail header fields. This object is created automaticly.
282 Do not free this object!}
283 property Header: TMessHeader read FHeader;
284 end;
285
286implementation
287
288{==============================================================================}
289
290constructor TMessHeader.Create;
291begin
292 inherited Create;
293 FToList := TStringList.Create;
294 FCCList := TStringList.Create;
295 FCustomHeaders := TStringList.Create;
296 FCharsetCode := GetCurCP;
297end;
298
299destructor TMessHeader.Destroy;
300begin
301 FCustomHeaders.Free;
302 FCCList.Free;
303 FToList.Free;
304 inherited Destroy;
305end;
306
307{==============================================================================}
308
309procedure TMessHeader.Clear;
310begin
311 FFrom := '';
312 FToList.Clear;
313 FCCList.Clear;
314 FSubject := '';
315 FOrganization := '';
316 FCustomHeaders.Clear;
317 FDate := 0;
318 FXMailer := '';
319 FReplyTo := '';
320 FMessageID := '';
321 FPriority := MP_unknown;
322end;
323
324procedure TMessHeader.EncodeHeaders(const Value: TStrings);
325var
326 n: Integer;
327 s: string;
328begin
329 if FDate = 0 then
330 FDate := Now;
331 for n := FCustomHeaders.Count - 1 downto 0 do
332 if FCustomHeaders[n] <> '' then
333 Value.Insert(0, FCustomHeaders[n]);
334 if FPriority <> MP_unknown then
335 case FPriority of
336 MP_high:
337 begin
338 Value.Insert(0, 'X-MSMAIL-Priority: High');
339 Value.Insert(0, 'X-Priority: 1');
340 Value.Insert(0, 'Priority: urgent');
341 end;
342 MP_low:
343 begin
344 Value.Insert(0, 'X-MSMAIL-Priority: low');
345 Value.Insert(0, 'X-Priority: 5');
346 Value.Insert(0, 'Priority: non-urgent');
347 end;
348 end;
349 if FReplyTo <> '' then
350 Value.Insert(0, 'Reply-To: ' + GetEmailAddr(FReplyTo));
351 if FMessageID <> '' then
352 Value.Insert(0, 'Message-ID: <' + trim(FMessageID) + '>');
353 if FXMailer = '' then
354 Value.Insert(0, 'X-mailer: Synapse - Pascal TCP/IP library by Lukas Gebauer')
355 else
356 Value.Insert(0, 'X-mailer: ' + FXMailer);
357 Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)');
358 if FOrganization <> '' then
359 Value.Insert(0, 'Organization: ' + InlineCodeEx(FOrganization, FCharsetCode));
360 s := '';
361 for n := 0 to FCCList.Count - 1 do
362 if s = '' then
363 s := InlineEmailEx(FCCList[n], FCharsetCode)
364 else
365 s := s + ', ' + InlineEmailEx(FCCList[n], FCharsetCode);
366 if s <> '' then
367 Value.Insert(0, 'CC: ' + s);
368 Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate));
369 if FSubject <> '' then
370 Value.Insert(0, 'Subject: ' + InlineCodeEx(FSubject, FCharsetCode));
371 s := '';
372 for n := 0 to FToList.Count - 1 do
373 if s = '' then
374 s := InlineEmailEx(FToList[n], FCharsetCode)
375 else
376 s := s + ', ' + InlineEmailEx(FToList[n], FCharsetCode);
377 if s <> '' then
378 Value.Insert(0, 'To: ' + s);
379 Value.Insert(0, 'From: ' + InlineEmailEx(FFrom, FCharsetCode));
380end;
381
382function TMessHeader.ParsePriority(value: string): TMessPriority;
383var
384 s: string;
385 x: integer;
386begin
387 Result := MP_unknown;
388 s := Trim(separateright(value, ':'));
389 s := Separateleft(s, ' ');
390 x := StrToIntDef(s, -1);
391 if x >= 0 then
392 case x of
393 1, 2:
394 Result := MP_High;
395 3:
396 Result := MP_Normal;
397 4, 5:
398 Result := MP_Low;
399 end
400 else
401 begin
402 s := lowercase(s);
403 if (s = 'urgent') or (s = 'high') or (s = 'highest') then
404 Result := MP_High;
405 if (s = 'normal') or (s = 'medium') then
406 Result := MP_Normal;
407 if (s = 'low') or (s = 'lowest')
408 or (s = 'no-priority') or (s = 'non-urgent') then
409 Result := MP_Low;
410 end;
411end;
412
413function TMessHeader.DecodeHeader(value: string): boolean;
414var
415 s, t: string;
416 cp: TMimeChar;
417begin
418 Result := True;
419 cp := FCharsetCode;
420 s := uppercase(value);
421 if Pos('X-MAILER:', s) = 1 then
422 begin
423 FXMailer := Trim(SeparateRight(Value, ':'));
424 Exit;
425 end;
426 if Pos('FROM:', s) = 1 then
427 begin
428 FFrom := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
429 Exit;
430 end;
431 if Pos('SUBJECT:', s) = 1 then
432 begin
433 FSubject := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
434 Exit;
435 end;
436 if Pos('ORGANIZATION:', s) = 1 then
437 begin
438 FOrganization := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
439 Exit;
440 end;
441 if Pos('TO:', s) = 1 then
442 begin
443 s := Trim(SeparateRight(Value, ':'));
444 repeat
445 t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp);
446 if t <> '' then
447 FToList.Add(t);
448 until s = '';
449 Exit;
450 end;
451 if Pos('CC:', s) = 1 then
452 begin
453 s := Trim(SeparateRight(Value, ':'));
454 repeat
455 t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp);
456 if t <> '' then
457 FCCList.Add(t);
458 until s = '';
459 Exit;
460 end;
461 if Pos('DATE:', s) = 1 then
462 begin
463 FDate := DecodeRfcDateTime(Trim(SeparateRight(Value, ':')));
464 Exit;
465 end;
466 if Pos('REPLY-TO:', s) = 1 then
467 begin
468 FReplyTo := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
469 Exit;
470 end;
471 if Pos('MESSAGE-ID:', s) = 1 then
472 begin
473 FMessageID := GetEmailAddr(Trim(SeparateRight(Value, ':')));
474 Exit;
475 end;
476 if Pos('PRIORITY:', s) = 1 then
477 begin
478 FPri := ParsePriority(value);
479 Exit;
480 end;
481 if Pos('X-PRIORITY:', s) = 1 then
482 begin
483 FXPri := ParsePriority(value);
484 Exit;
485 end;
486 if Pos('X-MSMAIL-PRIORITY:', s) = 1 then
487 begin
488 FXmsPri := ParsePriority(value);
489 Exit;
490 end;
491 if Pos('MIME-VERSION:', s) = 1 then
492 Exit;
493 if Pos('CONTENT-TYPE:', s) = 1 then
494 Exit;
495 if Pos('CONTENT-DESCRIPTION:', s) = 1 then
496 Exit;
497 if Pos('CONTENT-DISPOSITION:', s) = 1 then
498 Exit;
499 if Pos('CONTENT-ID:', s) = 1 then
500 Exit;
501 if Pos('CONTENT-TRANSFER-ENCODING:', s) = 1 then
502 Exit;
503 Result := False;
504end;
505
506procedure TMessHeader.DecodeHeaders(const Value: TStrings);
507var
508 s: string;
509 x: Integer;
510begin
511 Clear;
512 Fpri := MP_unknown;
513 Fxpri := MP_unknown;
514 Fxmspri := MP_unknown;
515 x := 0;
516 while Value.Count > x do
517 begin
518 s := NormalizeHeader(Value, x);
519 if s = '' then
520 Break;
521 if not DecodeHeader(s) then
522 FCustomHeaders.Add(s);
523 end;
524 if Fpri <> MP_unknown then
525 FPriority := Fpri
526 else
527 if Fxpri <> MP_unknown then
528 FPriority := Fxpri
529 else
530 if Fxmspri <> MP_unknown then
531 FPriority := Fxmspri
532end;
533
534function TMessHeader.FindHeader(Value: string): string;
535var
536 n: integer;
537begin
538 Result := '';
539 for n := 0 to FCustomHeaders.Count - 1 do
540 if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
541 begin
542 Result := Trim(SeparateRight(FCustomHeaders[n], ':'));
543 break;
544 end;
545end;
546
547procedure TMessHeader.FindHeaderList(Value: string; const HeaderList: TStrings);
548var
549 n: integer;
550begin
551 HeaderList.Clear;
552 for n := 0 to FCustomHeaders.Count - 1 do
553 if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
554 begin
555 HeaderList.Add(Trim(SeparateRight(FCustomHeaders[n], ':')));
556 end;
557end;
558
559{==============================================================================}
560
561constructor TMimeMess.Create;
562begin
563 CreateAltHeaders(TMessHeader);
564end;
565
566constructor TMimeMess.CreateAltHeaders(HeadClass: TMessHeaderClass);
567begin
568 inherited Create;
569 FMessagePart := TMimePart.Create;
570 FLines := TStringList.Create;
571 FHeader := HeadClass.Create;
572end;
573
574destructor TMimeMess.Destroy;
575begin
576 FMessagePart.Free;
577 FHeader.Free;
578 FLines.Free;
579 inherited Destroy;
580end;
581
582{==============================================================================}
583
584procedure TMimeMess.Clear;
585begin
586 FMessagePart.Clear;
587 FLines.Clear;
588 FHeader.Clear;
589end;
590
591{==============================================================================}
592
593function TMimeMess.AddPart(const PartParent: TMimePart): TMimePart;
594begin
595 if PartParent = nil then
596 Result := FMessagePart
597 else
598 Result := PartParent.AddSubPart;
599 Result.Clear;
600end;
601
602{==============================================================================}
603
604function TMimeMess.AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
605begin
606 Result := AddPart(PartParent);
607 with Result do
608 begin
609 Primary := 'Multipart';
610 Secondary := MultipartType;
611 Description := 'Multipart message';
612 Boundary := GenerateBoundary;
613 EncodePartHeader;
614 end;
615end;
616
617function TMimeMess.AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
618begin
619 Result := AddPart(PartParent);
620 with Result do
621 begin
622 Value.SaveToStream(DecodedLines);
623 Primary := 'text';
624 Secondary := 'plain';
625 Description := 'Message text';
626 Disposition := 'inline';
627 CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset, IdealCharsets);
628 EncodingCode := ME_QUOTED_PRINTABLE;
629 EncodePart;
630 EncodePartHeader;
631 end;
632end;
633
634function TMimeMess.AddPartTextEx(const Value: TStrings; const PartParent: TMimePart;
635 PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart;
636begin
637 Result := AddPart(PartParent);
638 with Result do
639 begin
640 Value.SaveToStream(DecodedLines);
641 Primary := 'text';
642 Secondary := 'plain';
643 Description := 'Message text';
644 Disposition := 'inline';
645 CharsetCode := PartCharset;
646 EncodingCode := PartEncoding;
647 ConvertCharset := not Raw;
648 EncodePart;
649 EncodePartHeader;
650 end;
651end;
652
653function TMimeMess.AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
654begin
655 Result := AddPart(PartParent);
656 with Result do
657 begin
658 Value.SaveToStream(DecodedLines);
659 Primary := 'text';
660 Secondary := 'html';
661 Description := 'HTML text';
662 Disposition := 'inline';
663 CharsetCode := UTF_8;
664 EncodingCode := ME_QUOTED_PRINTABLE;
665 EncodePart;
666 EncodePartHeader;
667 end;
668end;
669
670function TMimeMess.AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
671var
672 tmp: TStrings;
673begin
674 tmp := TStringList.Create;
675 try
676 tmp.LoadFromFile(FileName);
677 Result := AddPartText(tmp, PartParent);
678 Finally
679 tmp.Free;
680 end;
681end;
682
683function TMimeMess.AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
684var
685 tmp: TStrings;
686begin
687 tmp := TStringList.Create;
688 try
689 tmp.LoadFromFile(FileName);
690 Result := AddPartHTML(tmp, PartParent);
691 Finally
692 tmp.Free;
693 end;
694end;
695
696function TMimeMess.AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
697begin
698 Result := AddPart(PartParent);
699 Result.DecodedLines.LoadFromStream(Stream);
700 Result.MimeTypeFromExt(FileName);
701 Result.Description := 'Attached file: ' + FileName;
702 Result.Disposition := 'attachment';
703 Result.FileName := FileName;
704 Result.EncodingCode := ME_BASE64;
705 Result.EncodePart;
706 Result.EncodePartHeader;
707end;
708
709function TMimeMess.AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
710var
711 tmp: TMemoryStream;
712begin
713 tmp := TMemoryStream.Create;
714 try
715 tmp.LoadFromFile(FileName);
716 Result := AddPartBinary(tmp, ExtractFileName(FileName), PartParent);
717 finally
718 tmp.Free;
719 end;
720end;
721
722function TMimeMess.AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
723begin
724 Result := AddPart(PartParent);
725 Result.DecodedLines.LoadFromStream(Stream);
726 Result.MimeTypeFromExt(FileName);
727 Result.Description := 'Included file: ' + FileName;
728 Result.Disposition := 'inline';
729 Result.ContentID := Cid;
730 Result.FileName := FileName;
731 Result.EncodingCode := ME_BASE64;
732 Result.EncodePart;
733 Result.EncodePartHeader;
734end;
735
736function TMimeMess.AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
737var
738 tmp: TMemoryStream;
739begin
740 tmp := TMemoryStream.Create;
741 try
742 tmp.LoadFromFile(FileName);
743 Result :=AddPartHTMLBinary(tmp, ExtractFileName(FileName), Cid, PartParent);
744 finally
745 tmp.Free;
746 end;
747end;
748
749function TMimeMess.AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart;
750var
751 part: Tmimepart;
752begin
753 Result := AddPart(PartParent);
754 part := AddPart(result);
755 part.lines.addstrings(Value);
756 part.DecomposeParts;
757 with Result do
758 begin
759 Primary := 'message';
760 Secondary := 'rfc822';
761 Description := 'E-mail Message';
762 EncodePart;
763 EncodePartHeader;
764 end;
765end;
766
767function TMimeMess.AddPartMessFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
768var
769 tmp: TStrings;
770begin
771 tmp := TStringList.Create;
772 try
773 tmp.LoadFromFile(FileName);
774 Result := AddPartMess(tmp, PartParent);
775 Finally
776 tmp.Free;
777 end;
778end;
779
780{==============================================================================}
781
782procedure TMimeMess.EncodeMessage;
783var
784 l: TStringList;
785 x: integer;
786begin
787 //merge headers from THeaders and header field from MessagePart
788 l := TStringList.Create;
789 try
790 FHeader.EncodeHeaders(l);
791 x := IndexByBegin('CONTENT-TYPE', FMessagePart.Headers);
792 if x >= 0 then
793 l.add(FMessagePart.Headers[x]);
794 x := IndexByBegin('CONTENT-DESCRIPTION', FMessagePart.Headers);
795 if x >= 0 then
796 l.add(FMessagePart.Headers[x]);
797 x := IndexByBegin('CONTENT-DISPOSITION', FMessagePart.Headers);
798 if x >= 0 then
799 l.add(FMessagePart.Headers[x]);
800 x := IndexByBegin('CONTENT-ID', FMessagePart.Headers);
801 if x >= 0 then
802 l.add(FMessagePart.Headers[x]);
803 x := IndexByBegin('CONTENT-TRANSFER-ENCODING', FMessagePart.Headers);
804 if x >= 0 then
805 l.add(FMessagePart.Headers[x]);
806 FMessagePart.Headers.Assign(l);
807 finally
808 l.Free;
809 end;
810 FMessagePart.ComposeParts;
811 FLines.Assign(FMessagePart.Lines);
812end;
813
814{==============================================================================}
815
816procedure TMimeMess.DecodeMessage;
817begin
818 FHeader.Clear;
819 FHeader.DecodeHeaders(FLines);
820 FMessagePart.Lines.Assign(FLines);
821 FMessagePart.DecomposeParts;
822end;
823
824end.
Note: See TracBrowser for help on using the repository browser.