home *** CD-ROM | disk | FTP | other *** search
/ Chip 2003 January / Chip_2003-01_cd1.bin / zkuste / delphi / kompon / d567 / MAIL2000.ZIP / Mail2000.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-09-05  |  142.2 KB  |  6,224 lines
  1. (*
  2.  
  3. Component name...................: Mail2000 (Mail2000.pas)
  4. Classes implemented..............: TPOP2000, TSMTP2000, TMailMessage2000
  5. Version..........................: 1.10.1
  6. Status...........................: Beta
  7. Last update......................: 2001-09-04
  8. Author...........................: Marcello 'Panda' Tavares
  9. Homepage.........................: http://groups.yahoo.com/group/tmail2000
  10. Comments, bugs, suggestions to...: tmail2000@yahoogroups.com
  11. Language.........................: English
  12. Platform (tested)................: Windows 95/98/98SE/2000
  13. Requires.........................: Borland Delphi 5 Professional or better
  14.  
  15.  
  16. Features
  17. --------
  18.  
  19. 1. Retrieve and delete messages from POP3 servers;
  20.  
  21. 2. Send messages through SMTP servers;
  22.  
  23. 3. Parse MIME or UUCODE messages in header, body, alternative texts and
  24.    attachments;
  25.  
  26. 4. Create or modify MIME messages on-the-fly;
  27.  
  28. 5. HTML and embedded graphics support;
  29.  
  30. 6. Save or retrieve messages or attachments from files or streams;
  31.  
  32. 7. Ideal for automated e-mail processing.
  33.  
  34.  
  35. Know limitations
  36. ----------------
  37.  
  38. 1. Does not build UUCODE messages;
  39.  
  40. 2. Some problems when running on Windows NT/2000/ME (worth a try);
  41.  
  42. 3. Strange behaviours when netlink not present;
  43.  
  44. 4. Some troubles when handling very big messages;
  45.  
  46. 5. Some bugs and memory leaks.
  47.  
  48.  
  49. How to install
  50. --------------
  51.  
  52. Create a directory;
  53. Extract archive contents on it;
  54. Open Delphi;
  55. Click File/Close All;
  56. Click Component/Install Component;
  57. In "Unit File Name" select mail2000.pas;
  58. Click Ok;
  59. Select Yes to rebuild package;
  60. Wait for the message saying that the component is installed;
  61. Click File/Close All;
  62. Select Yes to save the package;
  63. Now try to run the demo.
  64.  
  65.  
  66. How to use
  67. ----------
  68.  
  69. The better way to learn is playing with the demo application.
  70. I'm not planning to type a help file.
  71. Fell free to mail your questions to me, expect aswer for 1-2 weeks.
  72. See 'Discussion Group' section below.
  73. Good luck!
  74.  
  75.  
  76. License stuff
  77. -------------
  78.  
  79. Mail2000 Copyleft 1999-2001
  80.  
  81. This software is provided as-is, without any express or implied
  82. warranty. In no event will the author be held liable for any damages
  83. arising from the use of this software.
  84.  
  85. As a freeware, the author reserve your rights to not provide support,
  86. requested changes in the code, specific versions, improvements of any
  87. kind and bug fixes. The main purpose is to help a little the programmers
  88. community over the world as a whole, not just one person or organization.
  89.  
  90. Permission is granted to anyone to use this software for any purpose,
  91. including commercial applications, and to alter it and redistribute it
  92. freely, subject to the following restrictions:
  93.  
  94. 1. The origin of this software must not be misrepresented, you must not
  95.    claim that you wrote the original software. If you use this software
  96.    in a product, an acknowledgment in the product documentation would be
  97.    appreciated.
  98.  
  99. 2. Altered source versions must be plainly marked as such, and must not be
  100.    misrepresented as being an original software.
  101.  
  102. 3. If you make changes to this software, you must send me the modified
  103.    integral version.
  104.  
  105. Please, consider my hard work.
  106.  
  107.  
  108. Thanks to
  109. ---------
  110.  
  111. Mariano D. Podesta (marianopodesta@usa.net) - The author of wlPop3
  112. component, from where I copied some decoding routines;
  113.  
  114. Sergio Kessler (sergio@perio.unlp.edu.ar) - The author of SakEmail
  115. component, from where I based my encoding and smtp algorithms;
  116.  
  117. Delphi Super Page (http://delphi.icm.edu.pl) - For providing
  118. the best way to find great programs and to join the Delphi community;
  119.  
  120. Yunarso Anang (yasx@hotmail.com) - For providing some functions for
  121. correct threatment of oriental charsets;
  122.  
  123. Christian Bormann (chris@xynx.de) - For giving a lot of suggestions
  124. and hard testing of this component;
  125.  
  126. Tommy Andersen (sorry, I lost his address) - For warning about some
  127. bugs in code;
  128.  
  129. Kunikazu Okada (kunikazu@okada.cc) - For detailed and careful suggestions
  130. to help mail composition;
  131.  
  132. Anderson (andermuller@conex.com.br) - Advices;
  133.  
  134. Rene de Jong (rmdejong@ism.nl) - Extensive bugfixes;
  135.  
  136. Hou Yg (yghou@yahoo.com) - Improvements;
  137.  
  138. Peter Baars (peter.baars@elburg.nl) - Bugfixes;
  139.  
  140. Giuseppe Mingolla (gmingolla@criptanet.it) - AttachStream method;
  141.  
  142. Milkopb (milkopb@yahoo.com) - Bugfixes;
  143.  
  144. David P. Schwartz (davids@desertigloo.com) - Suggestions and bugfixes;
  145.  
  146. John GBA (john@gbasolutions.co.uk) - Testing;
  147.  
  148. Anyone interested in helping me to improve this component, including you,
  149. just by downloading it.
  150.  
  151.  
  152. What's new in 1.1 version
  153. -------------------------
  154.  
  155. 1.  Fixed the threatment of encoded fields in header;
  156. 2.  Fixed some fake attachments found in message;
  157. 3.  Included a string property "LastMessage" containing the source of
  158.     last message retrieved;
  159. 4.  Now decoding file names;
  160. 5.  Fixed way to identify kind of host address;
  161. 6.  Added support for some tunnel proxy servers (eg via telnet port);
  162. 7.  Socket changed to non-blocking to improve communication;
  163. 8.  Fixed crashes when decoding encoded labels;
  164. 9.  Fixed header decoding with ansi charsets;
  165. 10. Fixed crashes when there are deleted messages on server;
  166. 11. Now recognizing text/??? file attachments;
  167. 12. Added Content-ID label at attachment header, now you can reference
  168.     attached files on HTML code as <img src=cid:file.ext>;
  169. 13. Improved a lot the speed when decoding messages;
  170. 14. Thousands of minor bug fixes.
  171.  
  172.  
  173. What's new in 1.2 version
  174. -------------------------
  175.  
  176. 1.  Added HELO command when talking to SMTP server;
  177. 2.  Changed CCO: fields (in portuguese) to BCC:
  178. 3.  It doesn't remove BCC: field after SMTP send anymore;
  179. 4.  Some random bugs fixed.
  180.  
  181.  
  182. What's new in 1.3 version
  183. -------------------------
  184.  
  185. 1.  POP and SMTP routines discontinued, but they will remain in the code;
  186. 2.  Some suggestions added.
  187.  
  188.  
  189. What's new in 1.4 version
  190. -------------------------
  191.  
  192. 1.  Improved UUCODE decoding;
  193. 2.  Range overflow bugs fixed;
  194. 3.  Changed MailMessage to MailMessage2000 to avoid class name conflicts.
  195.  
  196.  
  197. What's new in 1.5 version
  198. -------------------------
  199.  
  200. 1.  I decided to improve POP and SMTP, but still aren't reliable;
  201. 2.  Another sort of bug fixes;
  202. 3.  TPOP2000.RetrieveHeader procedure added;
  203. 4.  TPOP2000.DeleteAfterRetrieve property added;
  204. 5.  Improved threatment of messages with no text parts;
  205. 6.  Proxy support will remain, but has been discontinued;
  206. 7.  TMailMessage2000.LoadFromFile procedure added;
  207. 8.  TMailMessage2000.SaveToFile procedure added.
  208.  
  209.  
  210. What's new in 1.6 version
  211. -------------------------
  212.  
  213. 1.  Fixed expecting '+OK ' instead of '+OK' from SMTP;
  214. 2.  Stopped using TClientSocket.ReceiveLength, which is innacurate.
  215.  
  216.  
  217. What's new in 1.7 version
  218. -------------------------
  219.  
  220. 1.  Handling of 'Received' (hop) headers. Now it is possible to trace the
  221.     path e-mail went on;
  222. 2.  Again, bug fixes;
  223. 3.  Added properties to read (and just to read) 'To:' information and 'Cc:'
  224.     information using TStringList;
  225. 4.  Added procedures to set destinations in comma-delimited format;
  226. 5.  Removed text/rtf handling.
  227.  
  228.  
  229. What's new in 1.8 version
  230. -------------------------
  231.  
  232. 1.  Guess what? Bug fixes;
  233. 2.  Some memory leaks identified and fixed;
  234. 3.  Improved SMTP processing;
  235. 4.  Exception fixed in function 'Fill';
  236. 5.  Added 'AttachStream' method.
  237.  
  238.  
  239. What's new in 1.9 version
  240. -------------------------
  241.  
  242. 1.  Improved date handling;
  243. 2.  Improved 'Received' header handling;
  244. 3.  Added 'Mime-Version' field;
  245. 4.  Added 'Content-Length' field;
  246. 5.  Fixed bug when there is comma on sender/recipient name;
  247. 6.  Several compatibility improvements;
  248. 7.  Several redundancies removed;
  249. 8.  Added 'Embedded' option for attachments;
  250. 9.  Improved mail bulding structure and algorithm;
  251. 10. Added 'FindParts' to identify texts and attachments of foreing messages;
  252. 11. Removed 'GetAttachList' (now obsolete);
  253. 12. Added 'Normalize' to reformat foreing messages on Mail2000 standards;
  254. 13. Changed 'SetTextPlain' and 'SetTextHTML' to work with String type;
  255. 14. Added 'LoadFromStream' and 'SaveToStream';
  256. 15. Added 'MessageSource' read/write String property;
  257. 16. Added 'GetUIDL' method to POP component;
  258. 17. Added 'DetachFile' method;
  259. 18. Added 'Abort' method to POP and SMTP components;
  260. 19. Better handling of recipient fields (TMailRecipients);
  261. 20. Added 'AttachString' method;
  262. 21. Added 'AddHop' method;
  263. 22. Added 'SendMessageTo' method to SMTP component;
  264. 23. Added 'SendStringTo' method to SMTP component;
  265. 24. POP and SMTP components hard-tested;
  266. 25. POP and SMTP doesn't require MailMessage to work anymore;
  267. 26. Removed proxy support (but still working with ordinary proxy redirection);
  268. 27. Fixed one dot line causing SMTP to truncate the message;
  269. 28. Long lines on header now being wrapped;
  270. 29. Added 'TextEncoding' published property;
  271. 30. SendMessage will abort on first recipient rejected;
  272. 31. Treatment of dates without seconds;
  273. 32. Fixed progress events behavior.
  274.  
  275.  
  276. What's new in 1.10.x version
  277. ----------------------------
  278.  
  279. 1.  Now mail will be multipart only when needed;
  280. 2.  Fixed empty attachments issues;
  281. 3.  Fixed exceptions when handing text parts;
  282. 4.  Fixed exceptions when message has empty body;
  283. 5.  Now 'Normalize' is only needed when modifying a foreing message.
  284.  
  285.  
  286. Author data
  287. -----------
  288.  
  289. Marcello Roberto Tavares Pereira
  290. mycelo@yahoo.com
  291. http://mpanda.8m.com
  292. ICQ 5831833
  293. Sorocaba/SP - BRAZIL
  294. Spoken languages: Portuguese, English, Spanish
  295.  
  296.  
  297. Discussion Group
  298. ----------------
  299.  
  300. Please join TMail2000 group, exchange information about mailing
  301. application development with another power programmers, and receive
  302. suggestions, advices, bugfixes and updates about this component.
  303.  
  304. http://groups.yahoo.com/group/tmail2000
  305. tmail2000-subscribe@yahoogroups.com
  306.  
  307. This site stores all previous messages, you can find valuable
  308. information about this component there. If you have a question,
  309. please search this site before asking me, I will not post the
  310. same answer twice.
  311.  
  312. *)
  313.  
  314. unit Mail2000;
  315.  
  316. {Please don't remove the following line}
  317. {$BOOLEVAL OFF}
  318.  
  319. interface
  320.  
  321. uses
  322.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  323.   WinSock, ScktComp, Math, Registry, ExtCtrls;
  324.  
  325. type
  326.  
  327.   TMailPartList = class;
  328.   TMailMessage2000 = class;
  329.   TSocketTalk = class;
  330.  
  331.   TMessageSize = array of Integer;
  332.  
  333.   TSessionState = (stNone, stConnect, stUser, stPass, stStat, stList, stRetr, stDele, stUIDL, stHelo, stMail, stRcpt, stData, stSendData, stQuit);
  334.   TTalkError = (teGeneral, teSend, teReceive, teConnect, teDisconnect, teAccept, teTimeout, teNoError);
  335.   TEncodingType = (etBase64, etQuotedPrintable, etNoEncoding, et7Bit);
  336.   TNormalizer = (nrFirst, nrForce, nrAddText, nrAddAttach, nrAddEmbedded);
  337.  
  338.   TProgressEvent = procedure(Sender: TObject; Total, Current: Integer) of object;
  339.   TEndOfDataEvent = procedure(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean) of object;
  340.   TSocketTalkErrorEvent = procedure(Sender: TObject; SessionState: TSessionState; TalkError: TTalkError) of object;
  341.   TReceiveDataEvent = procedure(Sender: TObject; Sessionstate: TSessionState; Data: String; var ServerResult: Boolean) of object;
  342.  
  343.   TReceivedField = (reFrom, reBy, reFor, reDate, reNone);
  344.  
  345.   TReceived = record
  346.     From: String;
  347.     By: String;
  348.     Address: String;
  349.     Date: TDateTime;
  350.   end;
  351.  
  352.   { TMailPart - A recursive class to handle parts, subparts, and the mail by itself }
  353.  
  354.   TMailPart = class(TComponent)
  355.   private
  356.  
  357.     FHeader: TStringList {TMailText};
  358.     FBody: TMemoryStream;
  359.     FDecoded: TMemoryStream;
  360.     FParentBoundary: String;
  361.     FOwnerMessage: TMailMessage2000;
  362.     FSubPartList: TMailPartList;
  363.     FOwnerPart: TMailPart;
  364.     FIsDecoded: Boolean;
  365.     FEmbedded: Boolean;
  366.  
  367.     function GetAttachInfo: String;
  368.     function GetFileName: String;
  369.     function GetBoundary: String;
  370.     function GetSource: String;
  371.  
  372.     procedure Fill(Data: PChar; HasHeader: Boolean);
  373.     procedure SetSource(Text: String);
  374.  
  375.   public
  376.  
  377.     constructor Create(AOwner: TComponent); override;
  378.         destructor Destroy; override;
  379.  
  380.     function GetLabelValue(const cLabel: String): String;                     // Get the value of a label. e.g. Label: value
  381.     function GetLabelParamValue(const cLabel, Param: String): String;         // Get the value of a label parameter. e.g. Label: xxx; param=value
  382.     function LabelExists(const cLabel: String): Boolean;                      // Determine if a label exists
  383.     function LabelParamExists(const cLabel, Param: String): Boolean;          // Determine if a label parameter exists
  384.  
  385.     function Decode: Boolean;                                                 // Decode Body stream into Decoded stream and result true if successful
  386.  
  387.     procedure Encode(const ET: TEncodingType);
  388.     procedure EncodeText;                                                     // Encode Decoded stream into Body stream using quoted-printable
  389.     procedure EncodeBinary;                                                   // Encode Decoded stream into Body stream using Base64
  390.  
  391.     procedure SetLabelValue(const cLabel, cValue: String);                    // Set the value of a label
  392.     procedure SetLabelParamValue(const cLabel, cParam, cValue: String);       // Set the value of a label parameter
  393.  
  394.     procedure Remove;                                                         // Delete this mailpart from message
  395.  
  396.     procedure LoadFromFile(FileName: String);                                 // Load the data from a file
  397.     procedure SaveToFile(FileName: String);                                   // Save the data to a file
  398.     procedure LoadFromStream(Stream: TStream);                                // Load the data from a stream
  399.     procedure SaveToStream(Stream: TStream);                                  // Save the data to a stream
  400.  
  401.     property PartSource: String read GetSource write SetSource;
  402.     property Header: TStringList read FHeader;                                // The header text
  403.     property Body: TMemoryStream read FBody;                                  // The original body
  404.     property Decoded: TMemoryStream read FDecoded;                            // Stream with the body decoded
  405.     property SubPartList: TMailPartList read FSubPartList;                    // List of subparts of this mail part
  406.     property FileName: String read GetFileName;                               // Name of file when this mail part is an attached file
  407.     property AttachInfo: String read GetAttachInfo;                           // E.g. application/octet-stream
  408.     property OwnerMessage: TMailMessage2000 read FOwnerMessage;               // Main message that owns this mail part
  409.     property OwnerPart: TMailPart read FOwnerPart;                            // Father part of this part (can be the main message too)
  410.     property IsDecoded: Boolean read FIsDecoded;                              // If this part is decoded
  411.     property Embedded: Boolean read FEmbedded write FEmbedded;                // E.g. if is a picture inside HTML text
  412.   end;
  413.  
  414.   { TMailPartList - Just a collection of TMailPart's }
  415.  
  416.     TMailPartList = class(TList)
  417.     private
  418.  
  419.         function Get(const Index: Integer): TMailPart;
  420.  
  421.     public
  422.  
  423.         destructor Destroy; override;
  424.  
  425.         property Items[const Index: Integer]: TMailPart read Get; default;
  426.     end;
  427.  
  428.   { TMailRecipients - Handling of recipient fields }
  429.  
  430.   TMailRecipients = class(TObject)
  431.   private
  432.  
  433.     FMessage: TMailMessage2000;
  434.     FField: String;
  435.     FNames: TStringList;
  436.     FAddresses: TStringList;
  437.     FCheck: Integer;
  438.  
  439.     function GetName(const Index: Integer): String;
  440.     function GetAddress(const Index: Integer): String;
  441.     function GetCount: Integer;
  442.  
  443.     procedure SetName(const Index: Integer; const Name: String);
  444.     procedure SetAddress(const Index: Integer; const Address: String);
  445.  
  446.     function FindName(const Name: String): Integer;
  447.     function FindAddress(const Address: String): Integer;
  448.     function GetAllNames: String;
  449.     function GetAllAddresses: String;
  450.  
  451.     procedure HeaderToStrings;
  452.     procedure StringsToHeader;
  453.  
  454.   public
  455.  
  456.     constructor Create(MailMessage: TMailMessage2000; Field: String); //override;
  457.     destructor Destroy; override;
  458.  
  459.     procedure Add(const Name, Address: String);
  460.     procedure Replace(const Index: Integer; const Name, Address: String);
  461.     procedure Delete(const Index: Integer);
  462.     procedure SetAll(const Names, Addresses: String);
  463.     procedure AddNamesTo(const Str: TStrings);
  464.     procedure AddAddressesTo(const Str: TStrings);
  465.     procedure Clear;
  466.  
  467.     property Count: Integer read GetCount;
  468.     property Name[const Index: Integer]: String read GetName write SetName;
  469.     property Address[const Index: Integer]: String read GetAddress write SetAddress;
  470.     property ByName[const Name: String]: Integer read FindName;
  471.     property ByAddress[const Name: String]: Integer read FindAddress;
  472.     property AllNames: String read GetAllNames;
  473.     property AllAddresses: String read GetAllAddresses;
  474.   end;
  475.  
  476.   { TMailMessage2000 - A descendant of TMailPart with some tools to handle the mail }
  477.  
  478.   TMailMessage2000 = class(TMailPart)
  479.   private
  480.  
  481.     FAttachList: TMailPartList;
  482.     FTextPlain: TStringList;
  483.     FTextHTML: TStringList;
  484.     FTextPlainPart: TMailPart;
  485.     FTextHTMLPart: TMailPart;
  486.     FMixedPart: TMailPart;
  487.     FRelatedPart: TMailPart;
  488.     FAlternativePart: TMailPart;
  489.     FTextFather: TMailPart;
  490.     FCharset: String;
  491.     FOnProgress: TProgressEvent;
  492.     FNameCount: Integer;
  493.     FToList: TMailRecipients;
  494.     FCcList: TMailRecipients;
  495.     FBccList: TMailRecipients;
  496.     FTextEncoding: TEncodingType;
  497.  
  498.     FNeedRebuild: Boolean;
  499.     FNeedNormalize: Boolean;
  500.     FNeedFindParts: Boolean;
  501.  
  502.     function GetDestName(Field: String; const Index: Integer): String;
  503.     function GetDestAddress(Field: String; const Index: Integer): String;
  504.  
  505.     function GetReceivedCount: Integer;
  506.     function GetReceived(const Index: Integer): TReceived;
  507.  
  508.     function GetAttach(const FileName: String): TMailPart;
  509.  
  510.     function GetFromName: String;
  511.     function GetFromAddress: String;
  512.     function GetReplyToName: String;
  513.     function GetReplyToAddress: String;
  514.     function GetSubject: String;
  515.     function GetDate: TDateTime;
  516.     function GetMessageId: String;
  517.  
  518.     procedure PutText(Text: String; var Part: TMailPart; Content: String);
  519.     procedure RemoveText(var Part: TMailPart);
  520.  
  521.     procedure SetSubject(const Subject: String);
  522.     procedure SetDate(const Date: TDateTime);
  523.     procedure SetMessageId(const MessageId: String);
  524.  
  525.   public
  526.  
  527.     constructor Create(AOwner: TComponent); override;
  528.     destructor Destroy; override;
  529.  
  530.     procedure SetFrom(const Name, Address: String);                           // Create/modify the From: field
  531.     procedure SetReplyTo(const Name, Address: String);                        // Create/modify the Reply-To: field
  532.  
  533.     procedure FindParts;                                                      // Search for the attachments and texts
  534.     procedure Normalize(const Kind: TNormalizer = nrFirst);                                                      // Reconstruct message on Mail2000 standards (multipart/mixed)
  535.     procedure RebuildBody;                                                    // Build the raw mail body according to mailparts
  536.     procedure Reset;                                                          // Clear all stored data in the object
  537.     procedure SetTextPlain(const Text: String);                               // Create/modify a mailpart for text/plain (doesn't rebuild body)
  538.     procedure SetTextHTML(const Text: String);                                // Create/modify a mailpart for text/html (doesn't rebuild body)
  539.     procedure RemoveTextPlain;                                                // Remove the text/plain mailpart (doesn't rebuild body)
  540.     procedure RemoveTextHTML;                                                 // Remove the text/html mailpart (doesn't rebuild body)
  541.  
  542.     procedure AttachFile(const FileName: String; const ContentType: String = ''; const EncodingType: TEncodingType = etBase64; const IsEmbedded: Boolean = False);
  543.               // Create a mailpart and encode a file on it (doesn't rebuild body)
  544.     procedure AttachString(const Text, FileName: String; const ContentType: String = ''; const EncodingType: TEncodingType = etBase64; const IsEmbedded: Boolean = False);
  545.               // Create a mailpart and encode a string on it (doesn't rebuild body)
  546.     procedure AttachStream(const AStream: TStream; const FileName: String; const ContentType: String = ''; const EncodingType: TEncodingType = etBase64; const IsEmbedded: Boolean = False);
  547.               // Create a mailpart and encode a stream on it (doesn't rebuild body)
  548.     procedure DetachFile(const FileName: String);
  549.               // Remove attached file from message by name
  550.     procedure DetachFileIndex(const Index: Integer);
  551.               // Remove attached file from message by index of AttachList
  552.  
  553.     procedure AddHop(const From, By, Aplic, Address: String);                 // Add a 'Received:' in message header
  554.  
  555.     property Received[const Index: Integer]: TReceived read GetReceived;      // Retrieve the n-th 'Received' header
  556.     property ReceivedCount: Integer read GetReceivedCount;                    // Count the instances of 'Received' fields (hops)
  557.     property AttachByName[const FileName: String]: TMailPart read GetAttach;  // Returns the MailPart of an attachment by filename
  558.     property ToList: TMailRecipients read FToList;                            // Handling of To: recipients
  559.     property CcList: TMailRecipients read FCcList;                            // Handling of Cc: recipients
  560.     property BccList: TMailRecipients read FBccList;                          // Handling of Bcc: recipients
  561.  
  562.     property MessageSource: String read GetSource write SetSource;
  563.     property FromName: String read GetFromName;                               // Retrieve the From: name
  564.     property FromAddress: String read GetFromAddress;                         // Retrieve the From: address
  565.     property ReplyToName: String read GetReplyToName;                         // Retrieve the Reply-To: name
  566.     property ReplyToAddress: String read GetReplyToAddress;                   // Retrieve the Reply-To: address
  567.     property Subject: String read GetSubject write SetSubject;                // Retrieve or set the Subject: string
  568.     property Date: TDateTime read GetDate write SetDate;                      // Retrieve or set the Date: in TDateTime format
  569.     property MessageId: String read GetMessageId write SetMessageId;          // Retrieve or set the Message-Id:
  570.     property AttachList: TMailPartList read FAttachList;                      // A list of all attached files
  571.     property TextPlain: TStringList read FTextPlain;                          // A StringList with the text/plain from message
  572.     property TextHTML: TStringList read FTextHTML;                            // A StringList with the text/html from message
  573.     property TextPlainPart: TMailPart read FTextPlainPart;                    // The text/plain part
  574.     property TextHTMLPart: TMailPart read FTextHTMLPart;                      // The text/html part
  575.     property NeedRebuild: Boolean read FNeedRebuild;                          // True if RebuildBody is needed
  576.     property NeedNormalize: Boolean read FNeedNormalize;                      // True if message needs to be normalized
  577.     property NeedFindParts: Boolean read FNeedFindParts;                      // True if message has parts to be searched for
  578.  
  579.   published
  580.  
  581.     property Charset: String read FCharSet write FCharset;                       // Charset to build headers and text
  582.     property TextEncoding: TEncodingType read FTextEncoding write FTextEncoding; // How text will be encoded
  583.     property OnProgress: TProgressEvent read FOnProgress write FOnProgress;      // Occurs when storing message in memory
  584.   end;
  585.  
  586.   { TSocketTalk }
  587.  
  588.   TSocketTalk = class(TComponent)
  589.   private
  590.  
  591.     FTimeOut: Integer;
  592.     FExpectedEnd: String;
  593.     FLastResponse: String;
  594.     FDataSize: Integer;
  595.     FPacketSize: Integer;
  596.     FTalkError: TTalkError;
  597.     FSessionState: TSessionState;
  598.     FClientSocket: TClientSocket;
  599.     FWaitingServer: Boolean;
  600.     FTimer: TTimer;
  601.     FServerResult: Boolean;
  602.  
  603.     FOnProgress: TProgressEvent;
  604.     FOnEndOfData: TEndOfDataEvent;
  605.     FOnSocketTalkError: TSocketTalkErrorEvent;
  606.     FOnReceiveData: TReceiveDataEvent;
  607.     FOnDisconnect: TNotifyEvent;
  608.  
  609.     procedure SocketRead(Sender: TObject; Socket: TCustomWinSocket);
  610.     procedure SocketError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
  611.     procedure SocketDisconnect(Sender: TObject; Socket: TCustomWinSocket);
  612.     procedure Timer(Sender: TObject);
  613.  
  614.   public
  615.  
  616.     constructor Create(AOwner: TComponent); override;
  617.     destructor Destroy; override;
  618.  
  619.     procedure Talk(Buffer, EndStr: String; SessionState: TSessionState);
  620.     procedure Cancel;
  621.     procedure ForceState(SessionState: TSessionState);
  622.     procedure WaitServer;
  623.  
  624.     property LastResponse: String read FLastResponse;
  625.     property DataSize: Integer read FDataSize write FDataSize;
  626.     property PacketSize: Integer read FPacketSize write FPacketSize;
  627.     property TimeOut: Integer read FTimeOut write FTimeOut;
  628.     property TalkError: TTalkError read FTalkError;
  629.     property ClientSocket: TClientSocket read FClientSocket;
  630.     property ServerResult: Boolean read FServerResult;
  631.  
  632.     property OnEndOfData: TEndOfDataEvent read FOnEndOfData write FOnEndOfData;
  633.     property OnSocketTalkError: TSocketTalkErrorEvent read FOnSocketTalkError write FOnSocketTalkError;
  634.     property OnReceiveData: TReceiveDataEvent read FOnReceiveData write FOnReceiveData;
  635.     property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
  636.     property OnDisconnect: TNotifyEvent read FOnDisconnect write FOnDisconnect;
  637.   end;
  638.  
  639.   { TPOP2000 }
  640.  
  641.   TPOP2000 = class(TComponent)
  642.   private
  643.  
  644.     FMailMessage: TMailMessage2000;
  645.  
  646.     FSessionMessageCount: Integer;
  647.     FSessionMessageSize: TMessageSize;
  648.     FSessionConnected: Boolean;
  649.     FSessionLogged: Boolean;
  650.     FLastMessage: String;
  651.     FSocketTalk: TSocketTalk;
  652.  
  653.     FUserName: String;
  654.     FPassword: String;
  655.     FPort: Integer;
  656.     FHost: String;
  657.     FDeleteOnRetrieve: Boolean;
  658.  
  659.     procedure EndOfData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
  660.     procedure SocketTalkError(Sender: TObject; SessionState: TSessionState; TalkError: TTalkError);
  661.     procedure ReceiveData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
  662.     procedure SocketDisconnect(Sender: TObject);
  663.  
  664.     function GetTimeOut: Integer;
  665.     procedure SetTimeOut(Value: Integer);
  666.  
  667.     function GetProgress: TProgressEvent;
  668.     procedure SetProgress(Value: TProgressEvent);
  669.  
  670.     function GetLastResponse: String;
  671.  
  672.   public
  673.  
  674.     constructor Create(AOwner: TComponent); override;
  675.     destructor Destroy; override;
  676.  
  677.     function Connect: Boolean;                                                // Connect to mail server
  678.     function Login: Boolean;                                                  // Autenticate to mail server
  679.     function Quit: Boolean;                                                   // Logout and disconnect
  680.  
  681.     procedure Abort;                                                          // Force disconnect
  682.  
  683.     function RetrieveMessage(Number: Integer): Boolean;                       // Retrieve mail number # and put in MailMessage
  684.     function RetrieveHeader(Number: Integer; Lines: Integer = 0): Boolean;    // Retrieve header and put in MailMessage
  685.     function DeleteMessage(Number: Integer): Boolean;                         // Delete mail number #
  686.     function GetUIDL(Number: Integer): String;                                // Get UIDL from mail number #
  687.  
  688.     property SessionMessageCount: Integer read FSessionMessageCount;          // Number of messages found on server
  689.     property SessionMessageSize: TMessageSize read FSessionMessageSize;       // Dynamic array with size of the messages
  690.     property SessionConnected: Boolean read FSessionConnected;                // True if conencted to server
  691.     property SessionLogged: Boolean read FSessionLogged;                      // True if autenticated on server
  692.     property LastMessage: String read FLastMessage;                           // Last integral message text
  693.     property LastResponse: String read GetLastResponse;                       // Last string received from server
  694.  
  695.   published
  696.  
  697.     property UserName: String read FUserName write FUserName;                 // User name to login on server
  698.     property Password: String read FPassword write FPassword;                 // Password
  699.     property Port: Integer read FPort write FPort;                            // Port (usualy 110)
  700.     property Host: String read FHost write FHost;                             // Host address
  701.     property MailMessage: TMailMessage2000 read FMailMessage write FMailMessage;  // Message retrieved
  702.     property TimeOut: Integer read GetTimeOut write SetTimeOut;               // Max time to wait for server reply in seconds
  703.     property OnProgress: TProgressEvent read GetProgress write SetProgress;   // Occurs when receiving data from server
  704.     property DeleteOnRetrieve: Boolean read FDeleteOnRetrieve write FDeleteOnRetrieve;  // If message will be deleted after successful retrieve
  705.   end;
  706.  
  707.   { TSMTP2000 }
  708.  
  709.   TSMTP2000 = class(TComponent)
  710.   private
  711.  
  712.     FMailMessage: TMailMessage2000;
  713.  
  714.     FSessionConnected: Boolean;
  715.     FSocketTalk: TSocketTalk;
  716.     FPacketSize: Integer;
  717.  
  718.     FPort: Integer;
  719.     FHost: String;
  720.  
  721.     procedure EndOfData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
  722.     procedure SocketTalkError(Sender: TObject; SessionState: TSessionState; TalkError: TTalkError);
  723.     procedure ReceiveData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
  724.     procedure SocketDisconnect(Sender: TObject);
  725.  
  726.     function GetTimeOut: Integer;
  727.     procedure SetTimeOut(Value: Integer);
  728.  
  729.     function GetProgress: TProgressEvent;
  730.     procedure SetProgress(Value: TProgressEvent);
  731.  
  732.     function GetLastResponse: String;
  733.  
  734.   public
  735.  
  736.     constructor Create(AOwner: TComponent); override;
  737.     destructor Destroy; override;
  738.  
  739.     function Connect: Boolean;                                                // Connect to mail server
  740.     function Quit: Boolean;                                                   // Disconnect
  741.  
  742.     procedure Abort;                                                          // Force disconnect
  743.  
  744.     function SendMessage: Boolean;                                            // Send MailMessage to server
  745.     function SendMessageTo(const From, Dests: String): Boolean;               // Send MailMessage to specified recipients
  746.     function SendStringTo(const Msg, From, Dests: String): Boolean;           // Send string to specified recipients
  747.  
  748.     property SessionConnected: Boolean read FSessionConnected;                // True if conencted to server
  749.     property LastResponse: String read GetLastResponse;                       // Last string received from server
  750.  
  751.   published
  752.  
  753.     property Port: Integer read FPort write FPort;                            // Port (usualy 25)
  754.     property Host: String read FHost write FHost;                             // Host address
  755.     property TimeOut: Integer read GetTimeOut write SetTimeOut;               // Max time to wait for a response in seconds
  756.     property MailMessage: TMailMessage2000 read FMailMessage write FMailMessage;  // Message to send
  757.     property PacketSize: Integer read FPacketSize write FPacketSize;          // Size of packets to send to server
  758.     property OnProgress: TProgressEvent read GetProgress write SetProgress;   // Occurs when sending data to server
  759.   end;
  760.  
  761. procedure Register;
  762.  
  763. { Very useful functions ====================================================== }
  764.  
  765. function DecodeLine7Bit(Texto: String): String; forward;
  766. function EncodeLine7Bit(Texto, Charset: String): String; forward;
  767. function DecodeQuotedPrintable(Texto: String): String; forward;
  768. function EncodeQuotedPrintable(Texto: String; HeaderLine: Boolean): String; forward;
  769. function DecodeUUCODE(Encoded: PChar; Decoded: TMemoryStream): Boolean; forward;
  770. function DecodeLineUUCODE(const Buffer: String; Decoded: PChar): Integer; forward;
  771. function DecodeLineBASE64(const Buffer: String; Decoded: PChar): Integer; forward;
  772. function EncodeBASE64(Encoded: TMemoryStream {TMailText}; Decoded: TMemoryStream): Integer; forward;
  773. function NormalizeLabel(Texto: String): String; forward;
  774. function LabelValue(cLabel: String): String; forward;
  775. function WriteLabelValue(cLabel, Value: String): String; forward;
  776. function LabelParamValue(cLabel, cParam: String): String; forward;
  777. function WriteLabelParamValue(cLabel, cParam, Value: String): String; forward;
  778. function GetTimeZoneBias: Double; forward;
  779. function PadL(const Str: String; const Tam: Integer; const PadStr: String): String; forward;
  780. function GetMimeType(const FileName: String): String; forward;
  781. function GetMimeExtension(const MimeType: String): String; forward;
  782. function GenerateBoundary: String; forward;
  783. function SearchStringList(Lista: TStringList; const Chave: String; const Occorrence: Integer = 0): Integer; forward;
  784. procedure DataLine(var Data, Line: String; var nPos: Integer); forward;
  785. procedure DataLinePChar(const Data: PChar; const TotalLength: Integer; var LinePos, LineLen: Integer; var Line: PChar; var DataEnd: Boolean); forward;
  786. function IsIPAddress(const SS: String): Boolean; forward;
  787. function TrimSpace(const S: string): string; forward;
  788. function TrimLeftSpace(const S: string): string; forward;
  789. function TrimRightSpace(const S: string): string; forward;
  790. function MailDateToDelphiDate(const DateStr: String): TDateTime; forward;
  791. function DelphiDateToMailDate(const Date: TDateTime): String; forward;
  792. function ValidFileName(FileName: String): String; forward;
  793. function WrapHeader(Text: String): String; forward;
  794.  
  795. implementation
  796.  
  797. const
  798.   _C_T  = 'Content-Type';
  799.   _C_D  = 'Content-Disposition';
  800.   _C_TE = 'Content-Transfer-Encoding';
  801.   _C_ID = 'Content-ID';
  802.   _C_L  = 'Content-Length';
  803.   _CONT = 'Content-';
  804.   _FFR  = 'From';
  805.   _FRT  = 'Reply-To';
  806.   _M_V  = 'Mime-Version';
  807.   _M_ID = 'Message-ID';
  808.   _X_M  = 'X-Mailer';
  809.  
  810. const
  811.   _TXT  = 'text/';
  812.   _T_P  = 'text/plain';
  813.   _T_H  = 'text/html';
  814.   _MP   = 'multipart/';
  815.   _M_M  = 'multipart/mixed';
  816.   _M_A  = 'multipart/alternative';
  817.   _M_R  = 'multipart/related';
  818.   _M_RP = 'multipart/report';
  819.   _A_OS = 'application/octet-stream';
  820.   _BDRY = 'boundary';
  821.   _ATCH = 'attachment';
  822.   _INLN = 'inline';
  823.  
  824. const
  825.   _MIME_Msg = 'This is a multipart message in mime format.'#13#10;
  826.   _XMailer  = 'Mail2000 1.10 http://groups.yahoo.com/group/tmail2000';
  827.   _TXTFN    = 'textpart.txt';
  828.   _HTMLFN   = 'textpart.htm';
  829.   _CHARSET  = 'iso-8859-1';
  830.   _DATAEND1 = #13#10'.'#13#10;
  831.   _DATAEND2 = #13#10'..'#13#10;
  832.   _LINELEN  = 72;
  833.  
  834. procedure Register;
  835. begin
  836.  
  837.   RegisterComponents('Mail2000', [TPOP2000, TSMTP2000, TMailMessage2000]);
  838. end;
  839.  
  840. // Decode an encoded field e.g. =?iso-8859-1?x?xxxxxx=?=
  841.  
  842. function DecodeLine7Bit(Texto: String): String;
  843. var
  844.   Buffer: PChar;
  845.   Encoding: Char;
  846.   Size: Integer;
  847.   nPos0: Integer;
  848.   nPos1: Integer;
  849.   nPos2: Integer;
  850.   nPos3: Integer;
  851.   Found: Boolean;
  852.  
  853. begin
  854.  
  855.   Result := TrimSpace(Texto);
  856.  
  857.   repeat
  858.  
  859.     nPos0 := Pos('=?', Result);
  860.     Found := False;
  861.  
  862.     if nPos0 > 0 then
  863.     begin
  864.  
  865.       nPos1 := Pos('?', Copy(Result, nPos0+2, Length(Result)))+nPos0+1;
  866.       nPos2 := Pos('?=', Copy(Result, nPos1+1, Length(Result)))+nPos1;
  867.       nPos3 := Pos('?', Copy(Result, nPos2+1, Length(Result)))+nPos2;
  868.  
  869.       if nPos3 > nPos2 then
  870.       begin
  871.  
  872.         if Length(Result) > nPos3 then
  873.         begin
  874.  
  875.           if Result[nPos3+1] = '=' then
  876.           begin
  877.  
  878.             nPos2 := nPos3;
  879.           end;
  880.         end;
  881.       end;
  882.  
  883.       if (nPos1 > nPos0) and (nPos2 > nPos1) then
  884.       begin
  885.  
  886.         Texto := Copy(Result, nPos1+1, nPos2-nPos1-1);
  887.  
  888.         if (Length(Texto) >= 2) and (Texto[2] = '?') and (UpCase(Texto[1]) in ['B', 'Q', 'U']) then
  889.         begin
  890.  
  891.           Encoding := UpCase(Texto[1]);
  892.         end
  893.         else
  894.         begin
  895.  
  896.           Encoding := 'Q';
  897.         end;
  898.  
  899.         Texto := Copy(Texto, 3, Length(Texto)-2);
  900.  
  901.         case Encoding of
  902.  
  903.           'B':
  904.           begin
  905.  
  906.             GetMem(Buffer, Length(Texto));
  907.             Size := DecodeLineBASE64(Texto, Buffer);
  908.             Buffer[Size] := #0;
  909.             Texto := String(Buffer);
  910.           end;
  911.  
  912.           'Q':
  913.           begin
  914.  
  915.             while Pos('_', Texto) > 0 do
  916.               Texto[Pos('_', Texto)] := #32;
  917.  
  918.             Texto := DecodeQuotedPrintable(Texto);
  919.           end;
  920.  
  921.           'U':
  922.           begin
  923.  
  924.             GetMem(Buffer, Length(Texto));
  925.             Size := DecodeLineUUCODE(Texto, Buffer);
  926.             Buffer[Size] := #0;
  927.             Texto := String(Buffer);
  928.           end;
  929.         end;
  930.  
  931.         Result := Copy(Result, 1, nPos0-1)+Texto+Copy(Result,nPos2+2,Length(Result));
  932.         Found := True;
  933.       end;
  934.     end;
  935.  
  936.   until not Found;
  937. end;
  938.  
  939. // Encode a header field e.g. =?iso-8859-1?x?xxxxxx=?=
  940.  
  941. function EncodeLine7Bit(Texto, Charset: String): String;
  942. var
  943.   Loop: Integer;
  944.   Encode: Boolean;
  945.  
  946. begin
  947.  
  948.   Encode := False;
  949.  
  950.   for Loop := 1 to Length(Texto) do
  951.     if (Ord(Texto[Loop]) > 127) or (Ord(Texto[Loop]) < 32) then
  952.     begin
  953.  
  954.       Encode := True;
  955.       Break;
  956.     end;
  957.  
  958.   if Encode then
  959.     Result := '=?'+Charset+'?Q?'+EncodeQuotedPrintable(Texto, True)+'?='
  960.   else
  961.     Result := Texto;
  962. end;
  963.  
  964. // Decode a quoted-printable encoded string
  965.  
  966. function DecodeQuotedPrintable(Texto: String): String;
  967. var
  968.   nPos: Integer;
  969.   nLastPos: Integer;
  970.   lFound: Boolean;
  971.  
  972. begin
  973.  
  974.   Result := Texto;
  975.  
  976.   lFound := True;
  977.   nLastPos := 0;
  978.  
  979.   while lFound do
  980.   begin
  981.  
  982.     lFound := False;
  983.  
  984.     if nLastPos < Length(Result) then
  985.       nPos := Pos('=', Copy(Result, nLastPos+1, Length(Result)-nLastPos))+nLastPos
  986.     else
  987.       nPos := 0;
  988.  
  989.     if (nPos < (Length(Result)-1)) and (nPos > nLastPos) then
  990.     begin
  991.  
  992.       if (Result[nPos+1] in ['A'..'F', '0'..'9']) and (Result[nPos+2] in ['A'..'F', '0'..'9']) then
  993.       begin
  994.  
  995.         Insert(Char(StrToInt('$'+Result[nPos+1]+Result[nPos+2])), Result, nPos);
  996.         Delete(Result, nPos+1, 3);
  997.       end
  998.       else
  999.       begin
  1000.  
  1001.         if (Result[nPos+1] = #13) and (Result[nPos+2] = #10) then
  1002.         begin
  1003.  
  1004.           Delete(Result, nPos, 3);
  1005.           Dec(nPos, 3);
  1006.         end
  1007.         else
  1008.         begin
  1009.  
  1010.           if (Result[nPos+1] = #10) and (Result[nPos+2] = #13) then
  1011.           begin
  1012.  
  1013.             Delete(Result, nPos, 3);
  1014.             Dec(nPos, 3);
  1015.           end
  1016.           else
  1017.           begin
  1018.  
  1019.             if (Result[nPos+1] = #13) and (Result[nPos+2] <> #10) then
  1020.             begin
  1021.  
  1022.               Delete(Result, nPos, 2);
  1023.               Dec(nPos, 2);
  1024.             end
  1025.             else
  1026.             begin
  1027.  
  1028.               if (Result[nPos+1] = #10) and (Result[nPos+2] <> #13) then
  1029.               begin
  1030.  
  1031.                 Delete(Result, nPos, 2);
  1032.                 Dec(nPos, 2);
  1033.               end;
  1034.             end;
  1035.           end;
  1036.         end;
  1037.       end;
  1038.  
  1039.       lFound := True;
  1040.       nLastPos := nPos;
  1041.     end
  1042.     else
  1043.     begin
  1044.  
  1045.       if nPos = Length(Result) then
  1046.       begin
  1047.  
  1048.         Delete(Result, nPos, 1);
  1049.       end;
  1050.     end;
  1051.   end;
  1052. end;
  1053.  
  1054. // Encode a string in quoted-printable format
  1055.  
  1056. function EncodeQuotedPrintable(Texto: String; HeaderLine: Boolean): String;
  1057. var
  1058.   nPos: Integer;
  1059.   LineLen: Integer;
  1060.  
  1061. begin
  1062.  
  1063.   Result := '';
  1064.   LineLen := 0;
  1065.  
  1066.   for nPos := 1 to Length(Texto) do
  1067.   begin
  1068.  
  1069.     if (Texto[nPos] > #127) or
  1070.        (Texto[nPos] = '=') or
  1071.        ((Texto[nPos] <= #32) and HeaderLine) or
  1072.        ((Texto[nPos] in ['"', '_']) and HeaderLine) then
  1073.     begin
  1074.  
  1075.       Result := Result + '=' + PadL(Format('%2x', [Ord(Texto[nPos])]), 2, '0');
  1076.       Inc(LineLen, 3);
  1077.     end
  1078.     else
  1079.     begin
  1080.  
  1081.       Result := Result + Texto[nPos];
  1082.       Inc(LineLen);
  1083.     end;
  1084.  
  1085.     if Texto[nPos] = #13 then LineLen := 0;
  1086.  
  1087.     if (LineLen >= _LINELEN) and (not HeaderLine) then
  1088.     begin
  1089.  
  1090.       Result := Result + '='#13#10;
  1091.       LineLen := 0;
  1092.     end;
  1093.   end;
  1094. end;
  1095.  
  1096. // Decode an UUCODE encoded line
  1097.  
  1098. function DecodeLineUUCODE(const Buffer: String; Decoded: PChar): Integer;
  1099. const
  1100.     CHARS_PER_LINE = 45;
  1101.     Table: String = '`!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_';
  1102.  
  1103. var
  1104.     A24Bits: array[0..8 * CHARS_PER_LINE] of Boolean;
  1105.     i, j, k, b: Word;
  1106.     LineLen, ActualLen: Byte;
  1107.  
  1108.     function p_ByteFromTable(Ch: Char): Byte;
  1109.     var
  1110.         ij: Integer;
  1111.     begin
  1112.  
  1113.         ij := Pos(Ch, Table);
  1114.  
  1115.         if (ij > 64) or (ij = 0) then
  1116.         begin
  1117.             if Ch = #32 then
  1118.                 Result := 0 else
  1119.                 raise Exception.Create('UUCODE message format error');
  1120.         end else
  1121.             Result := ij - 1;
  1122.     end;
  1123.  
  1124. begin
  1125.  
  1126.   if Buffer = '' then
  1127.   begin
  1128.  
  1129.     Result := 0;
  1130.     Exit;
  1131.   end;
  1132.  
  1133.     LineLen := p_ByteFromTable(Buffer[1]);
  1134.     ActualLen := 4 * LineLen div 3;
  1135.  
  1136.     FillChar(A24Bits, 8 * CHARS_PER_LINE + 1, 0);
  1137.     Result := LineLen;
  1138.  
  1139.     if ActualLen <> (4 * CHARS_PER_LINE div 3) then
  1140.         ActualLen := Length(Buffer) - 1;
  1141.  
  1142.     k := 0;
  1143.     for i := 2 to ActualLen + 1 do
  1144.     begin
  1145.         b := p_ByteFromTable(Buffer[i]);
  1146.         for j := 5 downto 0 do
  1147.         begin
  1148.             A24Bits[k] := b and (1 shl j) > 0;
  1149.             Inc(k);
  1150.         end;
  1151.     end;
  1152.  
  1153.     k := 0;
  1154.     for i := 1 to CHARS_PER_LINE do
  1155.     begin
  1156.         b := 0;
  1157.         for j := 7 downto 0 do
  1158.         begin
  1159.             if A24Bits[k] then b := b or (1 shl j);
  1160.             Inc(k);
  1161.         end;
  1162.         Decoded[i-1] := Char(b);
  1163.     end;
  1164. end;
  1165.  
  1166. // Decode an UUCODE text
  1167.  
  1168. function DecodeUUCODE(Encoded: PChar; Decoded: TMemoryStream): Boolean;
  1169. var
  1170.   nTL, nPos, nLen: Integer;
  1171.   Line: PChar;
  1172.   LineDec: array[0..79] of Char;
  1173.   LineLen: Integer;
  1174.   DataEnd: Boolean;
  1175.  
  1176. begin
  1177.  
  1178.   Decoded.Clear;
  1179.  
  1180.   DataEnd := False;
  1181.   nPos := -1;
  1182.   nTL := StrLen(Encoded);
  1183.  
  1184.   DataLinePChar(Encoded, nTL, nPos, nLen, Line, DataEnd);
  1185.  
  1186.   while not DataEnd do
  1187.   begin
  1188.  
  1189.     if nLen > 0 then
  1190.     begin
  1191.  
  1192.       LineLen := DecodeLineUUCODE(String(Line), LineDec);
  1193.  
  1194.       if LineLen > 0 then
  1195.         Decoded.Write(LineDec[0], LineLen);
  1196.     end;
  1197.  
  1198.     DataLinePChar(Encoded, nTL, nPos, nLen, Line, DataEnd);
  1199.   end;
  1200.  
  1201.   Result := True;
  1202. end;
  1203.  
  1204. // Decode a BASE64 encoded line
  1205.  
  1206. function DecodeLineBASE64(const Buffer: String; Decoded: PChar): Integer;
  1207. var
  1208.   A1: array[1..4] of Byte;
  1209.   B1: array[1..3] of Byte;
  1210.   I, J: Integer;
  1211.   BytePtr, RealBytes: Integer;
  1212.  
  1213. begin
  1214.  
  1215.   BytePtr := 0;
  1216.   Result := 0;
  1217.  
  1218.   for J := 1 to Length(Buffer) do
  1219.   begin
  1220.  
  1221.     Inc(BytePtr);
  1222.  
  1223.     case Buffer[J] of
  1224.  
  1225.       'A'..'Z': A1[BytePtr] := Ord(Buffer[J])-65;
  1226.  
  1227.       'a'..'z': A1[BytePtr] := Ord(Buffer[J])-71;
  1228.  
  1229.       '0'..'9': A1[BytePtr] := Ord(Buffer[J])+4;
  1230.  
  1231.       '+': A1[BytePtr] := 62;
  1232.  
  1233.       '/': A1[BytePtr] := 63;
  1234.  
  1235.       '=': A1[BytePtr] := 64;
  1236.     end;
  1237.  
  1238.     if BytePtr = 4 then
  1239.     begin
  1240.  
  1241.       BytePtr := 0;
  1242.       RealBytes := 3;
  1243.  
  1244.       if A1[1] = 64 then RealBytes:=0;
  1245.  
  1246.       if A1[3] = 64 then
  1247.       begin
  1248.  
  1249.         A1[3] := 0;
  1250.         A1[4] := 0;
  1251.         RealBytes := 1;
  1252.       end;
  1253.  
  1254.       if A1[4] = 64 then
  1255.       begin
  1256.  
  1257.         A1[4] := 0;
  1258.         RealBytes := 2;
  1259.       end;
  1260.  
  1261.       B1[1] := A1[1]*4 + (A1[2] div 16);
  1262.       B1[2] := (A1[2] mod 16)*16+(A1[3] div 4);
  1263.       B1[3] := (A1[3] mod 4)*64 + A1[4];
  1264.  
  1265.       for I := 1 to RealBytes do
  1266.       begin
  1267.  
  1268.         Decoded[Result+I-1] := Chr(B1[I]);
  1269.       end;
  1270.  
  1271.       Inc(Result, RealBytes);
  1272.     end;
  1273.   end;
  1274. end;
  1275.  
  1276. // Padronize header labels; remove double spaces, decode quoted text, lower the cases, indentify mail addresses
  1277.  
  1278. function NormalizeLabel(Texto: String): String;
  1279. var
  1280.   Quote: Boolean;
  1281.   Quoted: String;
  1282.   Loop: Integer;
  1283.   lLabel: Boolean;
  1284.   sLabel: String;
  1285.   Value: String;
  1286.  
  1287. begin
  1288.  
  1289.   Quote := False;
  1290.   lLabel := True;
  1291.   Value := '';
  1292.   sLabel := '';
  1293.  
  1294.   for Loop := 1 to Length(Texto) do
  1295.   begin
  1296.  
  1297.     if (Texto[Loop] = '"') and (not lLabel) then
  1298.     begin
  1299.  
  1300.       Quote := not Quote;
  1301.  
  1302.       if Quote then
  1303.       begin
  1304.  
  1305.         Quoted := '';
  1306.       end
  1307.       else
  1308.       begin
  1309.  
  1310.         Value := Value + Quoted;
  1311.       end;
  1312.     end;
  1313.  
  1314.     if not Quote then
  1315.     begin
  1316.  
  1317.       if lLabel then
  1318.       begin
  1319.  
  1320.         if (sLabel = '') or (sLabel[Length(sLabel)] = '-') then
  1321.           sLabel := sLabel + UpCase(Texto[Loop])
  1322.         else
  1323.           if (Copy(sLabel, Length(sLabel)-1, 2) = '-I') and (UpCase(Texto[Loop]) = 'D') and
  1324.              (Loop < Length(Texto)) and (Texto[Loop+1] = ':') then
  1325.             sLabel := sLabel + 'D'
  1326.           else
  1327.             sLabel := sLabel + LowerCase(Texto[Loop]);
  1328.  
  1329.         if Texto[Loop] = ':' then
  1330.         begin
  1331.  
  1332.           lLabel := False;
  1333.           Value := '';
  1334.         end;
  1335.       end
  1336.       else
  1337.       begin
  1338.  
  1339.         if Texto[Loop] = #32 then
  1340.         begin
  1341.  
  1342.           Value := TrimRightSpace(Value) + #32;
  1343.         end
  1344.         else
  1345.         begin
  1346.  
  1347.           Value := Value + Texto[Loop];
  1348.         end;
  1349.       end;
  1350.     end
  1351.     else
  1352.     begin
  1353.  
  1354.       Quoted := Quoted + Texto[Loop];
  1355.     end;
  1356.   end;
  1357.  
  1358.   Result := TrimSpace(sLabel)+' '+TrimSpace(Value);
  1359. end;
  1360.  
  1361. // Return the value of a label; e.g. Label: value
  1362.  
  1363. function LabelValue(cLabel: String): String;
  1364. var
  1365.   Loop: Integer;
  1366.   Quote: Boolean;
  1367.   Value: Boolean;
  1368.   Ins: Boolean;
  1369.  
  1370. begin
  1371.  
  1372.   Quote := False;
  1373.   Value := False;
  1374.   Result := '';
  1375.  
  1376.   for Loop := 1 to Length(cLabel) do
  1377.   begin
  1378.  
  1379.     Ins := True;
  1380.  
  1381.     if cLabel[Loop] = '"' then
  1382.     begin
  1383.  
  1384.       Quote := not Quote;
  1385. //    Ins := False;
  1386.     end;
  1387.  
  1388.     if not Quote then
  1389.     begin
  1390.  
  1391.       if (cLabel[Loop] = ':') and (not Value) then
  1392.       begin
  1393.  
  1394.         Value := True;
  1395.         Ins := False;
  1396.       end
  1397.       else
  1398.       begin
  1399.  
  1400.         if (cLabel[Loop] = ';') and Value then
  1401.         begin
  1402.  
  1403.           Break;
  1404.         end;
  1405.       end;
  1406.     end;
  1407.  
  1408.     if Ins and Value then
  1409.     begin
  1410.  
  1411.       Result := Result + cLabel[Loop];
  1412.     end;
  1413.   end;
  1414.  
  1415.   Result := TrimSpace(Result);
  1416.  
  1417.   if (Copy(Result, 1, 1) = '"') and (Copy(Result, Length(Result), 1) = '"') then
  1418.     Result := Copy(Result, 2, Length(Result)-2);
  1419. end;
  1420.  
  1421. // Set the value of a label;
  1422.  
  1423. function WriteLabelValue(cLabel, Value: String): String;
  1424. var
  1425.   Loop: Integer;
  1426.   Quote: Boolean;
  1427.   ValPos, ValLen: Integer;
  1428.  
  1429. begin
  1430.  
  1431.   Quote := False;
  1432.   ValPos := 0;
  1433.   ValLen := -1;
  1434.  
  1435.   for Loop := 1 to Length(cLabel) do
  1436.   begin
  1437.  
  1438.     if cLabel[Loop] = '"' then
  1439.     begin
  1440.  
  1441.       Quote := not Quote;
  1442.     end;
  1443.  
  1444.     if not Quote then
  1445.     begin
  1446.  
  1447.       if (cLabel[Loop] = ':') and (ValPos = 0) then
  1448.       begin
  1449.  
  1450.         ValPos := Loop+1;
  1451.       end
  1452.       else
  1453.       begin
  1454.  
  1455.         if (cLabel[Loop] = ';') and (ValPos > 0) then
  1456.         begin
  1457.  
  1458.           ValLen := Loop - ValPos;
  1459.           Break;
  1460.         end;
  1461.       end;
  1462.     end;
  1463.   end;
  1464.  
  1465.   Result := cLabel;
  1466.  
  1467.   if (ValLen < 0) and (ValPos > 0) then
  1468.     ValLen := Length(cLabel) - ValPos + 1;
  1469.  
  1470.   if ValPos > 0 then
  1471.   begin
  1472.  
  1473.     Delete(Result, ValPos, ValLen);
  1474.     Insert(' '+TrimSpace(Value), Result, ValPos);
  1475.   end;
  1476. end;
  1477.  
  1478. // Return the value of a label parameter; e.g. Label: xxx; param=value
  1479.  
  1480. function LabelParamValue(cLabel, cParam: String): String;
  1481. var
  1482.   Loop: Integer;
  1483.   Quote: Boolean;
  1484.   Value: Boolean;
  1485.   Params: Boolean;
  1486.   ParamValue: Boolean;
  1487.   Ins: Boolean;
  1488.   Param: String;
  1489.  
  1490. begin
  1491.  
  1492.   Quote := False;
  1493.   Value := False;
  1494.   Params := False;
  1495.   ParamValue := False;
  1496.  
  1497.   Param := '';
  1498.   Result := '';
  1499.  
  1500.   cLabel := TrimSpace(cLabel);
  1501.  
  1502.   if Copy(cLabel, Length(cLabel), 1) <> ';' then cLabel := cLabel + ';';
  1503.  
  1504.   for Loop := 1 to Length(cLabel) do
  1505.   begin
  1506.  
  1507.     Ins := True;
  1508.  
  1509.     if cLabel[Loop] = '"' then
  1510.     begin
  1511.  
  1512.       Quote := not Quote;
  1513. //    Ins := False;
  1514.     end;
  1515.  
  1516.     if not Quote then
  1517.     begin
  1518.  
  1519.       if (cLabel[Loop] = ':') and (not Value) and (not Params) then
  1520.       begin
  1521.  
  1522.         Value := True;
  1523.         Params := False;
  1524.         ParamValue := False;
  1525.         Ins := False;
  1526.       end
  1527.       else
  1528.       begin
  1529.  
  1530.         if (cLabel[Loop] = ';') and (Value or Params) then
  1531.         begin
  1532.  
  1533.           Params := True;
  1534.           Value := False;
  1535.           ParamValue := False;
  1536.           Param := '';
  1537.           Ins := False;
  1538.         end
  1539.         else
  1540.         begin
  1541.  
  1542.           if (cLabel[Loop] = '=') and Params then
  1543.           begin
  1544.  
  1545.             ParamValue := UpperCase(TrimSpace(Param)) = UpperCase(TrimSpace(cParam));
  1546.             Ins := False;
  1547.             Param := '';
  1548.           end;
  1549.         end;
  1550.       end;
  1551.     end;
  1552.  
  1553.     if Ins and ParamValue then
  1554.     begin
  1555.  
  1556.       Result := Result + cLabel[Loop];
  1557.     end;
  1558.  
  1559.     if Ins and (not ParamValue) and Params then
  1560.     begin
  1561.  
  1562.       Param := Param + cLabel[Loop];
  1563.     end;
  1564.   end;
  1565.  
  1566.   Result := TrimSpace(Result);
  1567.  
  1568.   if (Copy(Result, 1, 1) = '"') and (Copy(Result, Length(Result), 1) = '"') then
  1569.     Result := Copy(Result, 2, Length(Result)-2);
  1570. end;
  1571.  
  1572. // Set the value of a label parameter;
  1573.  
  1574. function WriteLabelParamValue(cLabel, cParam, Value: String): String;
  1575. var
  1576.   Loop: Integer;
  1577.   Quote: Boolean;
  1578.   LabelValue: Boolean;
  1579.   Params: Boolean;
  1580.   ValPos, ValLen: Integer;
  1581.   Ins: Boolean;
  1582.   Param: String;
  1583.  
  1584. begin
  1585.  
  1586.   Quote := False;
  1587.   LabelValue := False;
  1588.   Params := False;
  1589.   ValPos := 0;
  1590.   ValLen := -1;
  1591.  
  1592.   Param := '';
  1593.   Result := '';
  1594.  
  1595.   cLabel := TrimSpace(cLabel);
  1596.  
  1597.   if cLabel[Length(cLabel)] <> ';' then
  1598.     cLabel := cLabel + ';';
  1599.  
  1600.   for Loop := 1 to Length(cLabel) do
  1601.   begin
  1602.  
  1603.     Ins := True;
  1604.  
  1605.     if cLabel[Loop] = '"' then
  1606.     begin
  1607.  
  1608.       Quote := not Quote;
  1609. //    Ins := False;
  1610.     end;
  1611.  
  1612.     if not Quote then
  1613.     begin
  1614.  
  1615.       if (cLabel[Loop] = ':') and (not LabelValue) and (not Params) then
  1616.       begin
  1617.  
  1618.         LabelValue := True;
  1619.         Params := False;
  1620.         ValPos := 0;
  1621.         ValLen := 0;
  1622.         Ins := False;
  1623.       end
  1624.       else
  1625.       begin
  1626.  
  1627.         if (cLabel[Loop] = ';') and (LabelValue or Params) then
  1628.         begin
  1629.  
  1630.           if Params and (ValPos > 0) then
  1631.           begin
  1632.  
  1633.             ValLen := Loop - ValPos;
  1634.             Break;
  1635.           end;
  1636.  
  1637.           Params := True;
  1638.           LabelValue := False;
  1639.           Param := '';
  1640.           Ins := False;
  1641.         end
  1642.         else
  1643.         begin
  1644.  
  1645.           if (cLabel[Loop] = '=') and Params then
  1646.           begin
  1647.  
  1648.             if UpperCase(TrimSpace(Param)) = UpperCase(TrimSpace(cParam)) then
  1649.             begin
  1650.  
  1651.               ValPos := Loop+1;
  1652.               ValLen := 0;
  1653.             end;
  1654.  
  1655.             Ins := False;
  1656.             Param := '';
  1657.           end;
  1658.         end;
  1659.       end;
  1660.     end;
  1661.  
  1662.     if Ins and (ValPos = 0) and Params then
  1663.     begin
  1664.  
  1665.       Param := Param + cLabel[Loop];
  1666.     end;
  1667.   end;
  1668.  
  1669.   Result := cLabel;
  1670.  
  1671.   if Result[Length(Result)] = ';' then
  1672.     Delete(Result, Length(Result), 1);
  1673.  
  1674.   if ValPos = 0 then
  1675.   begin
  1676.  
  1677.     Result := TrimSpace(Result) + '; ' + TrimSpace(cParam) + '=' + TrimSpace(Value);
  1678.   end
  1679.   else
  1680.   begin
  1681.  
  1682.     if (ValLen < 0) and (ValPos > 0) then
  1683.       ValLen := Length(cLabel) - ValPos + 1;
  1684.  
  1685.     Delete(Result, ValPos, ValLen);
  1686.     Insert(TrimSpace(Value), Result, ValPos);
  1687.   end;
  1688. end;
  1689.  
  1690. // Return the Timezone adjust in days
  1691.  
  1692. function GetTimeZoneBias: Double;
  1693. var
  1694.   TzInfo: TTimeZoneInformation;
  1695.  
  1696. begin
  1697.  
  1698.   case GetTimeZoneInformation(TzInfo) of
  1699.  
  1700.     1: Result := - (TzInfo.StandardBias + TzInfo.Bias) / (24*60);
  1701.  
  1702.     2: Result := - (TzInfo.DaylightBias + TzInfo.Bias) / (24*60);
  1703.  
  1704.     else Result := 0;
  1705.   end;
  1706. end;
  1707.  
  1708. // Fills left of string with char
  1709.  
  1710. function PadL(const Str: String; const Tam: Integer; const PadStr: String): String;
  1711. var
  1712.   TempStr: String;
  1713.  
  1714. begin
  1715.  
  1716.   TempStr := TrimLeftSpace(Str);
  1717.  
  1718.   if Length(TempStr) <= Tam then
  1719.   begin
  1720.  
  1721.     while Length(TempStr) < Tam do
  1722.       TempStr := PadStr + TempStr;
  1723.   end
  1724.   else
  1725.   begin
  1726.  
  1727.     TempStr := Copy(TempStr, Length(TempStr) - Tam + 1, Tam);
  1728.   end;
  1729.  
  1730.   Result := TempStr;
  1731. end;
  1732.  
  1733. // Get mime type of a file extension
  1734.  
  1735. function GetMimeType(const FileName: String): String;
  1736. var
  1737.   Key: string;
  1738.  
  1739. begin
  1740.  
  1741.   Result := '';
  1742.  
  1743.   with TRegistry.Create do
  1744.     try
  1745.  
  1746.       RootKey := HKEY_CLASSES_ROOT;
  1747.       Key := ExtractFileExt(FileName);
  1748.  
  1749.       if KeyExists(Key) then
  1750.       begin
  1751.  
  1752.         OpenKey(Key, False);
  1753.         Result := ReadString('Content Type');
  1754.         CloseKey;
  1755.       end;
  1756.  
  1757.     finally
  1758.  
  1759.       if Result = '' then
  1760.         Result := _A_OS;
  1761.  
  1762.       Free;
  1763.     end;
  1764. end;
  1765.  
  1766. // Get file extension of a mime type
  1767.  
  1768. function GetMimeExtension(const MimeType: String): String;
  1769. var
  1770.   Key: string;
  1771.  
  1772. begin
  1773.  
  1774.   Result := '';
  1775.  
  1776.   with TRegistry.Create do
  1777.     try
  1778.  
  1779.       RootKey := HKEY_CLASSES_ROOT;
  1780.  
  1781.       if OpenKey('MIME\Database\Content Type', False) then
  1782.       begin
  1783.  
  1784.         Key := MimeType;
  1785.  
  1786.         if KeyExists(Key) then
  1787.         begin
  1788.  
  1789.           OpenKey(Key,false);
  1790.           Result := ReadString('Extension');
  1791.           CloseKey;
  1792.         end;
  1793.       end;
  1794.  
  1795.     finally
  1796.  
  1797.       Free;
  1798.     end;
  1799. end;
  1800.  
  1801. // Generate a random boundary
  1802.  
  1803. function GenerateBoundary: String;
  1804. begin
  1805.  
  1806.   Result := _BDRY+PadL(Format('%8x', [Random($FFFFFFFF)]), 8, '0');
  1807. end;
  1808.  
  1809. // Encode in base64
  1810.  
  1811. function EncodeBASE64(Encoded: TMemoryStream {TMailText}; Decoded: TMemoryStream): Integer;
  1812. const
  1813.   _Code64: String[64] =
  1814.     ('ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/');
  1815. var
  1816.   I: LongInt;
  1817.   B: array[0..2279] of Byte;
  1818.   J, K, L, M, Quads: Integer;
  1819.   Stream: string[76];
  1820.   EncLine: String;
  1821.  
  1822. begin
  1823.  
  1824.   Encoded.Clear;
  1825.  
  1826.   Stream := '';
  1827.   Quads := 0;
  1828.   J := Decoded.Size div 2280;
  1829.  
  1830.   Decoded.Position := 0;
  1831.  
  1832.   for I := 1 to J do
  1833.   begin
  1834.  
  1835.     Decoded.Read(B, 2280);
  1836.  
  1837.     for M := 0 to 39 do
  1838.     begin
  1839.  
  1840.       for K := 0 to 18 do
  1841.       begin
  1842.  
  1843.         L:= 57*M + 3*K;
  1844.  
  1845.         Stream[Quads+1] := _Code64[(B[L] div 4)+1];
  1846.         Stream[Quads+2] := _Code64[(B[L] mod 4)*16 + (B[L+1] div 16)+1];
  1847.         Stream[Quads+3] := _Code64[(B[L+1] mod 16)*4 + (B[L+2] div 64)+1];
  1848.         Stream[Quads+4] := _Code64[B[L+2] mod 64+1];
  1849.  
  1850.         Inc(Quads, 4);
  1851.  
  1852.         if Quads = 76 then
  1853.         begin
  1854.  
  1855.           Stream[0] := #76;
  1856.           EncLine := Stream+#13#10;
  1857.           Encoded.Write(EncLine[1], Length(EncLine));
  1858.           Quads := 0;
  1859.         end;
  1860.       end;
  1861.     end;
  1862.   end;
  1863.  
  1864.   J := (Decoded.Size mod 2280) div 3;
  1865.  
  1866.   for I := 1 to J do
  1867.   begin
  1868.  
  1869.     Decoded.Read(B, 3);
  1870.  
  1871.     Stream[Quads+1] := _Code64[(B[0] div 4)+1];
  1872.     Stream[Quads+2] := _Code64[(B[0] mod 4)*16 + (B[1] div 16)+1];
  1873.     Stream[Quads+3] := _Code64[(B[1] mod 16)*4 + (B[2] div 64)+1];
  1874.     Stream[Quads+4] := _Code64[B[2] mod 64+1];
  1875.  
  1876.     Inc(Quads, 4);
  1877.  
  1878.     if Quads = 76 then
  1879.     begin
  1880.  
  1881.       Stream[0] := #76;
  1882.       EncLine := Stream+#13#10;
  1883.       Encoded.Write(EncLine[1], Length(EncLine));
  1884.       Quads := 0;
  1885.     end;
  1886.   end;
  1887.  
  1888.   if (Decoded.Size mod 3) = 2 then
  1889.   begin
  1890.  
  1891.     Decoded.Read(B, 2);
  1892.  
  1893.     Stream[Quads+1] := _Code64[(B[0] div 4)+1];
  1894.     Stream[Quads+2] := _Code64[(B[0] mod 4)*16 + (B[1] div 16)+1];
  1895.     Stream[Quads+3] := _Code64[(B[1] mod 16)*4 + 1];
  1896.     Stream[Quads+4] := '=';
  1897.  
  1898.     Inc(Quads, 4);
  1899.   end;
  1900.  
  1901.   if (Decoded.Size mod 3) = 1 then
  1902.   begin
  1903.  
  1904.     Decoded.Read(B, 1);
  1905.  
  1906.     Stream[Quads+1] := _Code64[(B[0] div 4)+1];
  1907.     Stream[Quads+2] := _Code64[(B[0] mod 4)*16 + 1];
  1908.     Stream[Quads+3] := '=';
  1909.     Stream[Quads+4] := '=';
  1910.     Inc(Quads, 4);
  1911.   end;
  1912.  
  1913.   Stream[0] := Chr(Quads);
  1914.  
  1915.   if Quads > 0 then
  1916.   begin
  1917.  
  1918.     EncLine := Stream+#13#10;
  1919.     Encoded.Write(EncLine[1], Length(EncLine));
  1920.   end;
  1921.  
  1922.   Result := Encoded.Size;
  1923. end;
  1924.  
  1925. // Search in a StringList
  1926.  
  1927. function SearchStringList(Lista: TStringList; const Chave: String; const Occorrence: Integer = 0): Integer;
  1928. var
  1929.   nPos: Integer;
  1930.   lAchou: Boolean;
  1931.   Casas: Integer;
  1932.   Temp: String;
  1933.   nOccor: Integer;
  1934.  
  1935. begin
  1936.  
  1937.   Casas := Length(Chave);
  1938.   lAchou := False;
  1939.   nPos := 0;
  1940.   nOccor := 0;
  1941.  
  1942.   try
  1943.  
  1944.     if Lista <> nil then
  1945.     begin
  1946.  
  1947.       while (not lAchou) and (nPos < Lista.Count) do
  1948.       begin
  1949.  
  1950.         Temp := Lista[nPos];
  1951.  
  1952.         if UpperCase(Copy(Temp, 1, Casas)) = UpperCase(Chave) then
  1953.         begin
  1954.  
  1955.           if nOccor = Occorrence then
  1956.           begin
  1957.  
  1958.             lAchou := True;
  1959.           end
  1960.           else
  1961.           begin
  1962.  
  1963.             Inc(nOccor);
  1964.           end;
  1965.         end;
  1966.  
  1967.         if not lAchou then
  1968.           Inc(nPos);
  1969.       end;
  1970.     end;
  1971.  
  1972.   finally
  1973.  
  1974.     if lAchou then
  1975.       result := nPos
  1976.     else
  1977.       result := -1;
  1978.   end;
  1979. end;
  1980.  
  1981. // Search lines into a string
  1982.  
  1983. procedure DataLine(var Data, Line: String; var nPos: Integer);
  1984. begin
  1985.  
  1986.   Line := '';
  1987.  
  1988.   while True do
  1989.   begin
  1990.  
  1991.     Line := Line + Data[nPos];
  1992.     Inc(nPos);
  1993.  
  1994.     if nPos > Length(Data) then
  1995.     begin
  1996.  
  1997.       nPos := -1;
  1998.       Break;
  1999.     end
  2000.     else
  2001.     begin
  2002.  
  2003.       if Length(Line) >= 2 then
  2004.       begin
  2005.  
  2006.         if (Line[Length(Line)-1] = #13) and (Line[Length(Line)] = #10) then
  2007.         begin
  2008.  
  2009.           Break;
  2010.         end;
  2011.       end;
  2012.     end;
  2013.   end;
  2014. end;
  2015.  
  2016. // Search lines into a string
  2017. // I need to do in this confusing way in order to improve performance
  2018.  
  2019. procedure DataLinePChar(const Data: PChar; const TotalLength: Integer; var LinePos, LineLen: Integer; var Line: PChar; var DataEnd: Boolean); assembler;
  2020. begin
  2021.  
  2022.   if LinePos >= 0 then
  2023.   begin
  2024.  
  2025.     Data[LinePos+LineLen] := #13;
  2026.     LinePos := LinePos+LineLen+2;
  2027.     LineLen := 0;
  2028.   end
  2029.   else
  2030.   begin
  2031.  
  2032.     LinePos := 0;
  2033.     LineLen := 0;
  2034.   end;
  2035.  
  2036.   while (LinePos+LineLen) < TotalLength do
  2037.   begin
  2038.  
  2039.     if Data[LinePos+LineLen] = #13 then
  2040.     begin
  2041.  
  2042.       if (LinePos+LineLen+1) < TotalLength then
  2043.       begin
  2044.  
  2045.         if Data[LinePos+LineLen+1] = #10 then
  2046.         begin
  2047.  
  2048.           Data[LinePos+LineLen] := #0;
  2049.           Line := @Data[LinePos];
  2050.           Exit;
  2051.         end;
  2052.       end;
  2053.     end;
  2054.  
  2055.     Inc(LineLen);
  2056.   end;
  2057.  
  2058.   if LinePos < TotalLength then
  2059.     Line := @Data[LinePos]
  2060.   else
  2061.     DataEnd := True;
  2062. end;
  2063.  
  2064. // Determine if string is a numeric IP or not (Thanks to Hou Yg yghou@yahoo.com)
  2065.  
  2066. function IsIPAddress(const SS: String): Boolean;
  2067. var
  2068.   Loop: Integer;
  2069.   P: String;
  2070.  
  2071. begin
  2072.  
  2073.   Result := True;
  2074.   P := '';
  2075.  
  2076.   for Loop := 1 to Length(SS)+1 do
  2077.   begin
  2078.  
  2079.     if (Loop > Length(SS)) or (SS[Loop] = '.') then
  2080.     begin
  2081.  
  2082.       if StrToIntDef(P, -1) < 0 then
  2083.       begin
  2084.  
  2085.         Result := False;
  2086.         Break;
  2087.       end;
  2088.  
  2089.       P := '';
  2090.     end
  2091.     else
  2092.     begin
  2093.  
  2094.       P := P + SS[Loop];
  2095.     end;
  2096.   end;
  2097. end;
  2098.  
  2099. // Remove leading and trailing spaces from string
  2100. // Thanks to Yunarso Anang (yasx@hotmail.com)
  2101.  
  2102. function TrimSpace(const S: string): string;
  2103. var
  2104.   I, L: Integer;
  2105.  
  2106. begin
  2107.  
  2108.   L := Length(S);
  2109.   I := 1;
  2110.  
  2111.   while (I <= L) and (S[I] = ' ') do
  2112.     Inc(I);
  2113.  
  2114.   if I > L then Result := '' else
  2115.   begin
  2116.  
  2117.     while S[L] = ' ' do
  2118.       Dec(L);
  2119.  
  2120.     Result := Copy(S, I, L - I + 1);
  2121.   end;
  2122. end;
  2123.  
  2124. // Remove left spaces from string
  2125. // Thanks to Yunarso Anang (yasx@hotmail.com)
  2126.  
  2127. function TrimLeftSpace(const S: string): string;
  2128. var
  2129.   I, L: Integer;
  2130.  
  2131. begin
  2132.  
  2133.   L := Length(S);
  2134.   I := 1;
  2135.  
  2136.   while (I <= L) and (S[I] = ' ') do
  2137.     Inc(I);
  2138.  
  2139.   Result := Copy(S, I, Maxint);
  2140. end;
  2141.  
  2142. // Remove right spaces from string
  2143. // Thanks to Yunarso Anang (yasx@hotmail.com)
  2144.  
  2145. function TrimRightSpace(const S: string): string;
  2146. var
  2147.   I: Integer;
  2148.  
  2149. begin
  2150.  
  2151.   I := Length(S);
  2152.  
  2153.   while (I > 0) and (S[I] = ' ') do
  2154.     Dec(I);
  2155.  
  2156.   Result := Copy(S, 1, I);
  2157. end;
  2158.  
  2159. // Convert date from message to Delphi format
  2160. // Returns zero in case of error
  2161.  
  2162. function MailDateToDelphiDate(const DateStr: String): TDateTime;
  2163. const
  2164.   Months: String = 'Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec,';
  2165.  
  2166. var
  2167.   Field, Loop: Integer;
  2168.   Hour, Min, Sec, Year, Month, Day: Double;
  2169.   sHour, sMin, sSec, sYear, sMonth, sDay, sTZ: String;
  2170.   HTZM, MTZM: Word;
  2171.   STZM: Integer;
  2172.   TZM: Double;
  2173.   Final: Double;
  2174.  
  2175. begin
  2176.  
  2177.   sHour := '';
  2178.   sMin := '';
  2179.   sSec := '';
  2180.   sYear := '';
  2181.   sMonth := '';
  2182.   sDay := '';
  2183.   sTZ := '';
  2184.  
  2185.   if DateStr <> '' then
  2186.   begin
  2187.  
  2188.     if DateStr[1] in ['0'..'9'] then
  2189.       Field := 1
  2190.     else
  2191.       Field := 0;
  2192.  
  2193.     for Loop := 1 to Length(DateStr) do
  2194.     begin
  2195.  
  2196.       if DateStr[Loop] in [#32, ':', '/'] then
  2197.       begin
  2198.  
  2199.         Inc(Field);
  2200.         if (Field = 6) and (DateStr[Loop] = #32) then Field := 7;
  2201.       end
  2202.       else
  2203.       begin
  2204.  
  2205.         case Field of
  2206.  
  2207.           1: sDay := sDay + DateStr[Loop];
  2208.           2: sMonth := sMonth + DateStr[Loop];
  2209.           3: sYear := sYear + DateStr[Loop];
  2210.           4: sHour := sHour + DateStr[Loop];
  2211.           5: sMin := sMin + DateStr[Loop];
  2212.           6: sSec := sSec + DateStr[Loop];
  2213.           7: sTZ := sTZ + DateStr[Loop];
  2214.         end;
  2215.       end;
  2216.     end;
  2217.  
  2218.     Hour := StrToIntDef(sHour, 0);
  2219.     Min := StrToIntDef(sMin, 0);
  2220.     Sec := StrToIntDef(sSec, 0);
  2221.     Year := StrToIntDef(sYear, 0);
  2222.     Day := StrToIntDef(sDay, 0);
  2223.  
  2224.     if sMonth[1] in ['0'..'9'] then
  2225.       Month := StrToIntDef(sMonth, 0)
  2226.     else
  2227.       Month := (Pos(sMonth, Months)-1) div 4 + 1;
  2228.  
  2229.     if Year < 100 then
  2230.     begin
  2231.  
  2232.       if Year < 50 then
  2233.         Year := 2000 + Year
  2234.       else
  2235.         Year := 1900 + Year;
  2236.     end;
  2237.  
  2238.     if (Year = 0) or (Month = 0) or (Year = 0) then
  2239.     begin
  2240.  
  2241.       Result := 0;
  2242.     end
  2243.     else
  2244.     begin
  2245.  
  2246.       if (sTZ = 'GMT') or (Length(Trim(sTZ)) <> 5) then
  2247.       begin
  2248.  
  2249.         STZM := 1;
  2250.         HTZM := 0;
  2251.         MTZM := 0;
  2252.       end
  2253.       else
  2254.       begin
  2255.  
  2256.         STZM := StrToIntDef(Copy(sTZ, 1, 1)+'1', 1);
  2257.         HTZM := StrToIntDef(Copy(sTZ, 2, 2), 0);
  2258.         MTZM := StrToIntDef(Copy(sTZ, 4, 2), 0);
  2259.       end;
  2260.  
  2261.       try
  2262.  
  2263.         TZM := EncodeTime(HTZM, MTZM, 0, 0)*STZM;
  2264.         Final := EncodeDate(Trunc(Year), Trunc(Month), Trunc(Day));
  2265.         Final := Final + Hour*(1/24) + Min*(1/24/60) + Sec*(1/24/60/60);
  2266.         Final := Final - TZM + GetTimeZoneBias;
  2267.  
  2268.         Result := Final;
  2269.  
  2270.       except
  2271.  
  2272.         Result := 0;
  2273.       end;
  2274.     end;
  2275.   end
  2276.   else
  2277.   begin
  2278.  
  2279.     Result := 0;
  2280.   end;
  2281. end;
  2282.  
  2283. // Convert numeric date to mail format
  2284.  
  2285. function DelphiDateToMailDate(const Date: TDateTime): String;
  2286. const
  2287.   Months: String = 'Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec,';
  2288.   Weeks: String = 'Sun,Mon,Tue,Wed,Thu,Fri,Sat,';
  2289.  
  2290. var
  2291.   TZH: Double;
  2292.   DateStr: String;
  2293.   TZStr: String;
  2294.   Day, Month, Year: Word;
  2295.  
  2296. begin
  2297.  
  2298.   TZH := GetTimeZoneBias;
  2299.   DecodeDate(Date, Year, Month, Day);
  2300.  
  2301.   if TZH < 0 then
  2302.   begin
  2303.  
  2304.     TZStr := '-'+FormatDateTime('hhmm', Abs(TZH));
  2305.   end
  2306.   else
  2307.   begin
  2308.  
  2309.     if TZH = 0 then
  2310.     begin
  2311.  
  2312.       TZStr := 'GMT'
  2313.     end
  2314.     else
  2315.     begin
  2316.  
  2317.       TZStr := '+'+FormatDateTime('hhmm', Abs(TZH));
  2318.     end;
  2319.   end;
  2320.  
  2321.   DateStr := Copy(Weeks, (DayOfWeek(Date)-1)*4+1, 3)+',';
  2322.   DateStr := DateStr + FormatDateTime(' dd ', Date);
  2323.   DateStr := DateStr + Copy(Months, (Month-1)*4+1, 3);
  2324.   DateStr := DateStr + FormatDateTime(' yyyy hh:nn:ss ', Date) + TZStr;
  2325.  
  2326.   Result := DateStr;
  2327. end;
  2328.  
  2329. // To make sure that a file name (without path!) is valid
  2330.  
  2331. function ValidFileName(FileName: String): String;
  2332. const
  2333.   InvChars: String = ':\/*?"<>|'#39;
  2334.  
  2335. var
  2336.   Loop: Integer;
  2337.  
  2338. begin
  2339.  
  2340.   FileName := Copy(TrimSpace(FileName), 1, 254);
  2341.   Result := '';
  2342.  
  2343.   for Loop := 1 to Length(FileName) do
  2344.   begin
  2345.  
  2346.     if (Ord(FileName[Loop]) < 32) or (Pos(FileName[Loop], InvChars) > 0) then
  2347.       Result := Result + '_'
  2348.     else
  2349.       Result := Result + FileName[Loop];
  2350.   end;
  2351. end;
  2352.  
  2353. // Wrap an entire message header
  2354.  
  2355. function WrapHeader(Text: String): String;
  2356. var
  2357.   Line: String;
  2358.   nPos: Integer;
  2359.   fPos: Integer;
  2360.   Quote: Char;
  2361.   Ok: Boolean;
  2362.  
  2363. begin
  2364.  
  2365.   Result := '';
  2366.   Text := AdjustLineBreaks(Text);
  2367.  
  2368.   while Copy(Text, Length(Text)-1, 2) = #13#10 do
  2369.     Delete(Text, Length(Text)-1, 2);
  2370.  
  2371.   while Text <> '' do
  2372.   begin
  2373.  
  2374.     nPos := Pos(#13#10, Text);
  2375.  
  2376.     if nPos > 0 then
  2377.     begin
  2378.  
  2379.       Line := Copy(Text, 1, nPos-1);
  2380.       Text := Copy(Text, nPos+2, Length(Text));
  2381.     end
  2382.     else
  2383.     begin
  2384.  
  2385.       Line := Text;
  2386.       Text := '';
  2387.     end;
  2388.  
  2389.     if Length(Line) <= _LINELEN then
  2390.     begin
  2391.  
  2392.       Result := Result + Line + #13#10;
  2393.     end
  2394.     else
  2395.     begin
  2396.  
  2397.       nPos := Length(Line);
  2398.       Quote := #0;
  2399.       Ok := False;
  2400.  
  2401.       if Line[1] <> #9 then
  2402.         fPos := Pos(':'#32, Line)+2
  2403.       else
  2404.         fPos := _LINELEN div 2;
  2405.  
  2406.       while nPos >= fPos do
  2407.       begin
  2408.  
  2409.         if (Quote = #0) and (Line[nPos] in [#39, '"']) then
  2410.           Quote := Line[nPos]
  2411.         else
  2412.           if (Quote <> #0) and (Line[nPos] = Quote) then
  2413.             Quote := #0;
  2414.  
  2415.         if (Quote = #0) and (nPos <= _LINELEN) and (Line[nPos] in [#32, ',', ';']) then
  2416.         begin
  2417.  
  2418.           Ok := True;
  2419.           Break;
  2420.         end;
  2421.  
  2422.         Dec(nPos);
  2423.       end;
  2424.  
  2425.       if Ok then
  2426.       begin
  2427.  
  2428.         if Line[nPos] = #32 then
  2429.           Result := Result + Copy(Line, 1, nPos-1) + #13#10#9
  2430.         else
  2431.           Result := Result + Copy(Line, 1, nPos) + #13#10#9;
  2432.  
  2433.         Text := Copy(Line, nPos+1, Length(Line)) + #13#10 + Text;
  2434.       end
  2435.       else
  2436.       begin
  2437.  
  2438.         Result := Result + Line + #13#10;
  2439.       end;
  2440.     end;
  2441.   end;
  2442. end;
  2443.  
  2444. { TMailPart ================================================================== }
  2445.  
  2446. // Initialize MailPart
  2447.  
  2448. constructor TMailPart.Create(AOwner: TComponent);
  2449. begin
  2450.  
  2451.   inherited Create(AOwner);
  2452.  
  2453.   FHeader := TStringList.Create;
  2454.   FBody := TMemoryStream.Create;
  2455.   FDecoded := TMemoryStream.Create;
  2456.   FSubPartList := TMailPartList.Create;
  2457.   FOwnerPart := nil;
  2458.   FOwnerMessage := nil;
  2459.   FEmbedded := False;
  2460. end;
  2461.  
  2462. // Finalize MailPart
  2463.  
  2464. destructor TMailPart.Destroy;
  2465. var
  2466.   Loop: Integer;
  2467.  
  2468. begin
  2469.  
  2470.   for Loop := 0 to FSubPartList.Count-1 do
  2471.     FSubPartList.Items[Loop].Destroy;
  2472.  
  2473.   FHeader.Free;
  2474.   FBody.Free;
  2475.   FDecoded.Free;
  2476.   FSubPartList.Free;
  2477.  
  2478.   inherited Destroy;
  2479. end;
  2480.  
  2481. // Return the value of a label from the header like "To", "Subject"
  2482.  
  2483. function TMailPart.GetLabelValue(const cLabel: String): String;
  2484. var
  2485.   Loop: Integer;
  2486.  
  2487. begin
  2488.  
  2489.   Result := '';
  2490.   Loop := SearchStringList(FHeader, cLabel+':');
  2491.  
  2492.   if Loop >= 0 then
  2493.     Result := TrimSpace(LabelValue(FHeader[Loop]));
  2494.  
  2495.   if Length(Result) > 2 then
  2496.   begin
  2497.  
  2498.     if (Result[1] in ['"', #39]) and
  2499.        (Result[Length(Result)] in ['"', #39]) then
  2500.       Result := Copy(Result, 2, Length(Result)-2);
  2501.   end;
  2502. end;
  2503.  
  2504. // Return de value of a parameter of a value from the header
  2505.  
  2506. function TMailPart.GetLabelParamValue(const cLabel, Param: String): String;
  2507. var
  2508.   Loop: Integer;
  2509.  
  2510. begin
  2511.  
  2512.   Result := '';
  2513.   Loop := SearchStringList(FHeader, cLabel+':');
  2514.  
  2515.   if Loop >= 0 then
  2516.     Result := TrimSpace(LabelParamValue(FHeader[Loop], Param));
  2517.  
  2518.   if Length(Result) > 2 then
  2519.   begin
  2520.  
  2521.     if (Result[1] in ['"', #39]) and
  2522.        (Result[Length(Result)] in ['"', #39]) then
  2523.       Result := Copy(Result, 2, Length(Result)-2);
  2524.   end;
  2525. end;
  2526.  
  2527. // Set the value of a label
  2528.  
  2529. procedure TMailPart.SetLabelValue(const cLabel, cValue: String);
  2530. var
  2531.   Loop: Integer;
  2532.  
  2533. begin
  2534.  
  2535.   Loop := SearchStringList(FHeader, cLabel+':');
  2536.  
  2537.   if cValue <> '' then
  2538.   begin
  2539.  
  2540.     if Loop < 0 then
  2541.     begin
  2542.  
  2543.       FHeader.Add(cLabel+': ');
  2544.       Loop := FHeader.Count-1;
  2545.     end;
  2546.  
  2547.     FHeader[Loop] := WriteLabelValue(FHeader[Loop], cValue);
  2548.   end
  2549.   else
  2550.   begin
  2551.  
  2552.     if Loop >= 0 then
  2553.     begin
  2554.  
  2555.       FHeader.Delete(Loop);
  2556.     end;
  2557.   end;
  2558. end;
  2559.  
  2560. // Set the value of a label parameter
  2561.  
  2562. procedure TMailPart.SetLabelParamValue(const cLabel, cParam, cValue: String);
  2563. var
  2564.   Loop: Integer;
  2565.  
  2566. begin
  2567.  
  2568.   Loop := SearchStringList(FHeader, cLabel+':');
  2569.  
  2570.   if Loop < 0 then
  2571.   begin
  2572.  
  2573.     FHeader.Add(cLabel+': ');
  2574.     Loop := FHeader.Count-1;
  2575.   end;
  2576.  
  2577.   FHeader[Loop] := WriteLabelParamValue(FHeader[Loop], cParam, cValue);
  2578. end;
  2579.  
  2580. // Look for a label in the header
  2581.  
  2582. function TMailPart.LabelExists(const cLabel: String): Boolean;
  2583. begin
  2584.  
  2585.   Result := SearchStringList(FHeader, cLabel+':') >= 0;
  2586. end;
  2587.  
  2588. // Look for a parameter in a label in the header
  2589.  
  2590. function TMailPart.LabelParamExists(const cLabel, Param: String): Boolean;
  2591. var
  2592.   Loop: Integer;
  2593.  
  2594. begin
  2595.  
  2596.   Result := False;
  2597.   Loop := SearchStringList(FHeader, cLabel+':');
  2598.  
  2599.   if Loop >= 0 then
  2600.     Result := TrimSpace(LabelParamValue(FHeader[Loop], Param)) <> '';
  2601. end;
  2602.  
  2603. // Divide header and body; normalize header;
  2604.  
  2605. procedure TMailPart.Fill(Data: PChar; HasHeader: Boolean);
  2606. const
  2607.   CRLF: array[0..2] of Char = (#13, #10, #0);
  2608.  
  2609. var
  2610.   Loop: Integer;
  2611.   BoundStart: array[0..99] of Char;
  2612.   BoundEnd: array[0..99] of Char;
  2613.   InBound: Boolean;
  2614.   IsBoundStart: Boolean;
  2615.   IsBoundEnd: Boolean;
  2616.   BoundStartLen: Integer;
  2617.   BoundEndLen: Integer;
  2618.   PartText: PChar;
  2619.   DataEnd: Boolean;
  2620.   MultPart: Boolean;
  2621.   NoParts: Boolean;
  2622.   InUUCode: Boolean;
  2623.   UUFile, UUBound: String;
  2624.   Part: TMailPart;
  2625.   nPos: Integer;
  2626.   nLen: Integer;
  2627.   nTL: Integer;
  2628.   nSPos: Integer;
  2629.   Line: PChar;
  2630.   SChar: Char;
  2631.  
  2632. begin
  2633.  
  2634.   if (FOwnerMessage = nil) or (not (FOwnerMessage is TMailMessage2000)) then
  2635.   begin
  2636.  
  2637.     Exception.Create(Self.Name+': TMailPart must be owned by a TMailMessage2000');
  2638.     Exit;
  2639.   end;
  2640.  
  2641.   for Loop := 0 to FSubPartList.Count-1 do
  2642.     FSubPartList.Items[Loop].Destroy;
  2643.  
  2644.   FHeader.Clear;
  2645.   FBody.Clear;
  2646.   FDecoded.Clear;
  2647.   FSubPartList.Clear;
  2648.   FIsDecoded := False;
  2649.   FEmbedded := False;
  2650.   FOwnerMessage.FNeedRebuild := True;
  2651.   FOwnerMessage.FNeedNormalize := True;
  2652.   FOwnerMessage.FNeedFindParts := True;
  2653.  
  2654.   nPos := -1;
  2655.   DataEnd := False;
  2656.   nTL := StrLen(Data);
  2657.   nSPos := nTL+1;
  2658.  
  2659.   if (Self is TMailMessage2000) and Assigned(FOwnerMessage.FOnProgress) then
  2660.   begin
  2661.  
  2662.     FOwnerMessage.FOnProgress(Self, nTL, 0);
  2663.     Application.ProcessMessages;
  2664.   end;
  2665.  
  2666.   if HasHeader then
  2667.   begin
  2668.  
  2669.     // Get Header
  2670.  
  2671.     DataLinePChar(Data, nTL, nPos, nLen, Line, DataEnd);
  2672.  
  2673.     while not DataEnd do
  2674.     begin
  2675.  
  2676.       if nLen = 0 then
  2677.       begin
  2678.  
  2679.         Break;
  2680.       end
  2681.       else
  2682.       begin
  2683.  
  2684.         if (Line[0] in [#9, #32]) and (FHeader.Count > 0) then
  2685.         begin
  2686.  
  2687.           FHeader[FHeader.Count-1] := FHeader[FHeader.Count-1] + #32 + String(PChar(@Line[1]));
  2688.         end
  2689.         else
  2690.         begin
  2691.  
  2692.           FHeader.Add(String(Line));
  2693.         end;
  2694.       end;
  2695.  
  2696.       DataLinePChar(Data, nTL, nPos, nLen, Line, DataEnd);
  2697.  
  2698.       if (Self is TMailMessage2000) and Assigned(FOwnerMessage.FOnProgress) then
  2699.       begin
  2700.  
  2701.         FOwnerMessage.FOnProgress(Self, nTL, nPos+1);
  2702.         Application.ProcessMessages;
  2703.       end;
  2704.     end;
  2705.  
  2706.     for Loop := 0 to FHeader.Count-1 do
  2707.       FHeader[Loop] := NormalizeLabel(FHeader[Loop]);
  2708.   end;
  2709.  
  2710.   MultPart := LowerCase(Copy(GetLabelValue(_C_T), 1, 10)) = _MP;
  2711.   InBound := False;
  2712.   IsBoundStart := False;
  2713.   IsBoundEnd := False;
  2714.   UUBound := '';
  2715.  
  2716.   if MultPart then
  2717.   begin
  2718.  
  2719.     StrPCopy(BoundStart, '--'+GetBoundary);
  2720.     StrPCopy(BoundEnd, '--'+GetBoundary+'--');
  2721.     BoundStartLen := StrLen(BoundStart);
  2722.     BoundEndLen := StrLen(BoundEnd);
  2723.     NoParts := False;
  2724.   end
  2725.   else
  2726.   begin
  2727.  
  2728.     if LabelExists(_C_T) then
  2729.     begin
  2730.  
  2731.       NoParts := True;
  2732.       BoundStartLen := 0;
  2733.       BoundEndLen := 0;
  2734.     end
  2735.     else
  2736.     begin
  2737.  
  2738.       StrPCopy(BoundStart, 'begin 6');
  2739.       StrPCopy(BoundEnd, 'end');
  2740.       BoundStartLen := StrLen(BoundStart);
  2741.       BoundEndLen := StrLen(BoundEnd);
  2742.       NoParts := False;
  2743.     end;
  2744.   end;
  2745.  
  2746.   PartText := nil;
  2747.  
  2748.   // Get Body
  2749.  
  2750.   DataLinePChar(Data, nTL, nPos, nLen, Line, DataEnd);
  2751.  
  2752.   while (not DataEnd) and (not InBound) do
  2753.   begin
  2754.  
  2755.     if (not NoParts) and (((Line[0] = '-') and (Line[1] = '-')) or ((Line[0] = 'b') and (Line[1] = 'e'))) then
  2756.     begin
  2757.  
  2758.       IsBoundStart := StrLComp(Line, BoundStart, BoundStartLen) = 0;
  2759.     end;
  2760.  
  2761.     if NoParts or (not IsBoundStart) then
  2762.     begin
  2763.  
  2764.       if PartText = nil then
  2765.       begin
  2766.  
  2767.         PartText := Line;
  2768.         nSPos := nPos;
  2769.       end;
  2770.  
  2771.       DataLinePChar(Data, nTL, nPos, nLen, Line, DataEnd);
  2772.  
  2773.       if (Self is TMailMessage2000) and Assigned(FOwnerMessage.FOnProgress) then
  2774.       begin
  2775.  
  2776.         FOwnerMessage.FOnProgress(Self, nTL, nPos+1);
  2777.         Application.ProcessMessages;
  2778.       end;
  2779.     end
  2780.     else
  2781.     begin
  2782.  
  2783.       InBound := True;
  2784.     end;
  2785.   end;
  2786.  
  2787.   if nPos > nSPos then
  2788.   begin
  2789.  
  2790.     SChar := Data[nPos];
  2791.     Data[nPos] := #0;
  2792.  
  2793.     if PartText <> nil then
  2794.       FBody.Write(PartText[0], nPos-nSPos);
  2795.  
  2796.     Data[nPos] := SChar;
  2797.   end;
  2798.  
  2799.   if not NoParts then
  2800.   begin
  2801.  
  2802.     PartText := nil;
  2803.  
  2804.     if MultPart then
  2805.     begin
  2806.  
  2807.       // Get Mime parts
  2808.  
  2809.       while not DataEnd do
  2810.       begin
  2811.  
  2812.         if IsBoundStart or IsBoundEnd then
  2813.         begin
  2814.  
  2815.           if (PartText <> nil) and (PartText[0] <> #0) then
  2816.           begin
  2817.  
  2818.             Part := TMailPart.Create(Self.FOwnerMessage);
  2819.             Part.FOwnerPart := Self;
  2820.             Part.FOwnerMessage := Self.FOwnerMessage;
  2821.  
  2822.             SChar := Data[nPos-2];
  2823.             Data[nPos-2] := #0;
  2824.             Part.Fill(PartText, True);
  2825.             Data[nPos-2] := SChar;
  2826.  
  2827.             Part.FParentBoundary := GetBoundary;
  2828.             FSubPartList.Add(Part);
  2829.             PartText := nil;
  2830.           end;
  2831.  
  2832.           if IsBoundEnd then
  2833.           begin
  2834.  
  2835.             Break;
  2836.           end;
  2837.  
  2838.           IsBoundStart := False;
  2839.           IsBoundEnd := False;
  2840.         end
  2841.         else
  2842.         begin
  2843.  
  2844.           if PartText = nil then
  2845.           begin
  2846.  
  2847.             PartText := Line;
  2848.           end;
  2849.         end;
  2850.  
  2851.         DataLinePChar(Data, nTL, nPos, nLen, Line, DataEnd);
  2852.  
  2853.         if (Self is TMailMessage2000) and Assigned(FOwnerMessage.FOnProgress) then
  2854.         begin
  2855.  
  2856.           FOwnerMessage.FOnProgress(Self, nTL, nPos+1);
  2857.           Application.ProcessMessages;
  2858.         end;
  2859.  
  2860.         if not DataEnd then
  2861.         begin
  2862.  
  2863.           if (Line[0] = '-') and (Line[1] = '-') then
  2864.           begin
  2865.  
  2866.             IsBoundStart := StrLComp(Line, BoundStart, BoundStartLen) = 0;
  2867.  
  2868.             if not IsBoundStart then
  2869.             begin
  2870.  
  2871.               IsBoundEnd := StrLComp(Line, BoundEnd, BoundEndLen) = 0;
  2872.             end;
  2873.           end;
  2874.         end;
  2875.       end;
  2876.     end
  2877.     else
  2878.     begin
  2879.  
  2880.       // Get UUCode parts
  2881.  
  2882.       InUUCode := IsBoundStart;
  2883.  
  2884.       while not DataEnd do
  2885.       begin
  2886.  
  2887.         if IsBoundStart then
  2888.         begin
  2889.  
  2890.           if UUBound = '' then
  2891.           begin
  2892.  
  2893.             GetMem(PartText, FBody.Size+1);
  2894.             UUBound := GenerateBoundary;
  2895.             StrLCopy(PartText, FBody.Memory, FBody.Size);
  2896.             PartText[FBody.Size] := #0;
  2897.  
  2898.             Part := TMailPart.Create(Self.FOwnerMessage);
  2899.             Part.FOwnerPart := Self;
  2900.             Part.FOwnerMessage := Self.FOwnerMessage;
  2901.             Part.Fill(PChar(EncodeQuotedPrintable(String(PartText), False)), False);
  2902.             Part.FParentBoundary := UUBound;
  2903.             Part.SetLabelValue(_C_T, _T_P);
  2904.             Part.SetLabelParamValue(_C_T, 'charset', '"'+FOwnerMessage.FCharset+'"');
  2905.             Part.SetLabelValue(_C_TE, 'quoted-printable');
  2906.  
  2907.             FSubPartList.Add(Part);
  2908.             SetLabelValue(_C_T, '');
  2909.             SetLabelValue(_C_T, _M_M);
  2910.             SetLabelParamValue(_C_T, _BDRY, '"'+UUBound+'"');
  2911.  
  2912.             FreeMem(PartText);
  2913.           end;
  2914.  
  2915.           PartText := nil;
  2916.           IsBoundStart := False;
  2917.           UUFile := TrimSpace(Copy(String(Line), 11, 999));
  2918.         end
  2919.         else
  2920.         begin
  2921.  
  2922.           if IsBoundEnd then
  2923.           begin
  2924.  
  2925.             Part := TMailPart.Create(Self.FOwnerMessage);
  2926.             Part.FOwnerPart := Self;
  2927.             Part.FOwnerMessage := Self.FOwnerMessage;
  2928.  
  2929.             SChar := Data[nPos-2];
  2930.             Data[nPos-2] := #0;
  2931.             DecodeUUCODE(PartText, Part.FDecoded);
  2932.             Data[nPos-2] := SChar;
  2933.  
  2934.             Part.EncodeBinary;
  2935.             Part.FParentBoundary := UUBound;
  2936.             Part.SetLabelValue(_C_T, GetMimeType(UUFile));
  2937.             Part.SetLabelValue(_C_TE, 'base64');
  2938.             Part.SetLabelValue(_C_D, _ATCH);
  2939.             Part.SetLabelParamValue(_C_T, 'name', '"'+UUFile+'"');
  2940.             Part.SetLabelParamValue(_C_D, 'filename', '"'+UUFile+'"');
  2941.  
  2942.             FSubPartList.Add(Part);
  2943.             PartText := nil;
  2944.             IsBoundEnd := False;
  2945.           end
  2946.           else
  2947.           begin
  2948.  
  2949.             if PartText = nil then
  2950.             begin
  2951.  
  2952.               PartText := Line;
  2953.             end;
  2954.           end;
  2955.         end;
  2956.  
  2957.         DataLinePChar(Data, nTL, nPos, nLen, Line, DataEnd);
  2958.  
  2959.         if (Self is TMailMessage2000) and Assigned(FOwnerMessage.FOnProgress) then
  2960.         begin
  2961.  
  2962.           FOwnerMessage.FOnProgress(Self, nTL, nPos+1);
  2963.           Application.ProcessMessages;
  2964.         end;
  2965.  
  2966.         if not DataEnd then
  2967.         begin
  2968.  
  2969.           if (Line[0] = 'b') and (Line[1] = 'e') then
  2970.           begin
  2971.  
  2972.             IsBoundStart := StrLComp(Line, BoundStart, BoundStartLen) = 0;
  2973.             InUUCode := True;
  2974.           end;
  2975.  
  2976.           if (not IsBoundStart) and InUUCode then
  2977.           begin
  2978.  
  2979.             if (Line[0] = 'e') and (Line[1] = 'n') and (Line[2] = 'd') then
  2980.             begin
  2981.  
  2982.               IsBoundEnd := True;
  2983.               InUUCode := False;
  2984.             end;
  2985.           end;
  2986.         end;
  2987.       end;
  2988.     end;
  2989.   end;
  2990.  
  2991.   if (Self is TMailMessage2000) and Assigned(FOwnerMessage.FOnProgress) then
  2992.   begin
  2993.  
  2994.     FOwnerMessage.FOnProgress(Self, nTL, nTL);
  2995.     Application.ProcessMessages;
  2996.   end;
  2997. end;
  2998.  
  2999. // Remove mailpart from its owner
  3000.  
  3001. procedure TMailPart.Remove;
  3002. begin
  3003.  
  3004.   if (FOwnerPart <> nil) and (Self <> FOwnerMessage) and
  3005.      (FOwnerPart.FSubPartList.IndexOf(Self) >= 0) then
  3006.   begin
  3007.  
  3008.     FOwnerPart.FSubPartList.Delete(FOwnerPart.FSubPartList.IndexOf(Self));
  3009.     FOwnerPart := nil;
  3010.   end;
  3011. end;
  3012.  
  3013. // Fill part with a file contents
  3014.  
  3015. procedure TMailPart.LoadFromFile(FileName: String);
  3016. var
  3017.   SL: TStringList;
  3018.  
  3019. begin
  3020.  
  3021.   SL := TStringList.Create;
  3022.   SL.LoadFromFile(FileName);
  3023.  
  3024.   Fill(PChar(SL.Text), True);
  3025.  
  3026.   SL.Free;
  3027. end;
  3028.  
  3029. // Save the part data to a file
  3030.  
  3031. procedure TMailPart.SaveToFile(FileName: String);
  3032. var
  3033.   SL: TStringList;
  3034.  
  3035. begin
  3036.  
  3037.   SL := TStringList.Create;
  3038.   SL.Text := GetSource;
  3039.  
  3040.   try
  3041.  
  3042.     SL.SaveToFile(FileName);
  3043.  
  3044.   finally
  3045.  
  3046.     SL.Free;
  3047.   end;
  3048. end;
  3049.  
  3050. // Fill part with a stream contents
  3051.  
  3052. procedure TMailPart.LoadFromStream(Stream: TStream);
  3053. var
  3054.   Buffer: PChar;
  3055.  
  3056. begin
  3057.  
  3058.   GetMem(Buffer, Stream.Size+1);
  3059.   Stream.Position := 0;
  3060.   Stream.ReadBuffer(Buffer[0], Stream.Size);
  3061.   Buffer[Stream.Size] := #0;
  3062.   Fill(Buffer, True);
  3063.   FreeMem(Buffer);
  3064. end;
  3065.  
  3066. // Save the part data to a stream
  3067.  
  3068. procedure TMailPart.SaveToStream(Stream: TStream);
  3069. var
  3070.   Text: String;
  3071.  
  3072. begin
  3073.  
  3074.   Text := GetSource;
  3075.   Stream.Size := Length(Text);
  3076.   Stream.Position := 0;
  3077.   Stream.WriteBuffer(Text[1], Length(Text));
  3078. end;
  3079.  
  3080. // Fill part with a string contents
  3081.  
  3082. procedure TMailPart.SetSource(Text: String);
  3083. begin
  3084.  
  3085.   Fill(PChar(Text), True);
  3086. end;
  3087.  
  3088. // Copy the part data to a string
  3089.  
  3090. function TMailPart.GetSource: String;
  3091. begin
  3092.  
  3093.   SetLength(Result, FBody.Size);
  3094.   FBody.Position := 0;
  3095.   FBody.ReadBuffer(Result[1], FBody.Size);
  3096.   Result := WrapHeader(FHeader.Text)+#13#10+Result;
  3097. end;
  3098.  
  3099. // Get file name of attachment
  3100.  
  3101. function TMailPart.GetFileName: String;
  3102. var
  3103.   Name: String;
  3104.  
  3105. begin
  3106.  
  3107.   Name := '';
  3108.  
  3109.   if LabelParamExists(_C_T, 'name') then
  3110.   begin
  3111.  
  3112.     Name := GetLabelParamValue(_C_T, 'name');
  3113.   end
  3114.   else
  3115.   begin
  3116.  
  3117.     if LabelParamExists(_C_D, 'filename') then
  3118.     begin
  3119.  
  3120.       Name := GetLabelParamValue(_C_D, 'filename');
  3121.     end
  3122.     else
  3123.     begin
  3124.  
  3125.       if LabelExists(_C_ID) then
  3126.       begin
  3127.  
  3128.         Name := GetLabelValue(_C_ID);
  3129.       end
  3130.       else
  3131.       begin
  3132.  
  3133.         if LabelExists(_C_T) then
  3134.         begin
  3135.  
  3136.           Name := GetLabelValue(_C_T)+GetMimeExtension(GetLabelValue(_C_T));
  3137.         end
  3138.         else
  3139.         begin
  3140.  
  3141.           Name := 'unknown';
  3142.         end;
  3143.       end;
  3144.     end;
  3145.   end;
  3146.  
  3147.   Name := DecodeLine7Bit(Name);
  3148.  
  3149.   if Pos('.', Name) = 0 then
  3150.     Name := Name + GetMimeExtension(GetLabelValue(_C_T));
  3151.  
  3152.   Result := ValidFileName(Name);
  3153. end;
  3154.  
  3155. // Get kind of attachment
  3156.  
  3157. function TMailPart.GetAttachInfo: String;
  3158. begin
  3159.  
  3160.   Result := LowerCase(GetLabelValue(_C_T));
  3161. end;
  3162.  
  3163. // Get boundary of this part (when it is a multipart header)
  3164.  
  3165. function TMailPart.GetBoundary: String;
  3166. begin
  3167.  
  3168.   Result := GetLabelParamValue(_C_T, _BDRY);
  3169. end;
  3170.  
  3171. // Decode mail part
  3172.  
  3173. function TMailPart.Decode;
  3174. var
  3175.   Content: String;
  3176.   Encoding: String;
  3177.   Data: String;
  3178.   DecoLine: String;
  3179.   Buffer: PChar;
  3180.   Size: Integer;
  3181.   nPos: Integer;
  3182.  
  3183. begin
  3184.  
  3185.   Result := True;
  3186.  
  3187.   if FIsDecoded then
  3188.     Exit;
  3189.  
  3190.   FIsDecoded := True;
  3191.  
  3192.   if FBody.Size = 0 then Exit;
  3193.  
  3194.   Content := GetAttachInfo;
  3195.   Encoding := GetLabelValue(_C_TE);
  3196.  
  3197.   FDecoded.Clear;
  3198.  
  3199.   if (Encoding = 'quoted-printable') or (Encoding = '7bit') then
  3200.   begin
  3201.  
  3202.     GetMem(Buffer, FBody.Size+1);
  3203.     StrLCopy(Buffer, FBody.Memory, FBody.Size);
  3204.     Buffer[FBody.Size] := #0;
  3205.     DecoLine := DecodeQuotedPrintable(Buffer);
  3206.     FreeMem(Buffer);
  3207.  
  3208.     GetMem(Buffer, Length(DecoLine)+1);
  3209.     StrPCopy(Buffer, DecoLine);
  3210.     FDecoded.Write(Buffer^, Length(DecoLine));
  3211.     FreeMem(Buffer);
  3212.   end
  3213.   else
  3214.   begin
  3215.  
  3216.     if Encoding = 'base64' then
  3217.     begin
  3218.  
  3219.       nPos := 1;
  3220.  
  3221.       SetLength(Data, FBody.Size);
  3222.       FBody.Position := 0;
  3223.       FBody.ReadBuffer(Data[1], FBody.Size);
  3224.  
  3225.       while nPos >= 0 do
  3226.       begin
  3227.  
  3228.         DataLine(Data, DecoLine, nPos);
  3229.  
  3230.         GetMem(Buffer, 132);
  3231.         Size := DecodeLineBASE64(TrimSpace(DecoLine), Buffer);
  3232.  
  3233.         if Size > 0 then
  3234.           FDecoded.Write(Buffer^, Size);
  3235.  
  3236.         FreeMem(Buffer);
  3237.       end;
  3238.     end
  3239.     else
  3240.     begin
  3241.  
  3242.       if Encoding = 'uucode' then
  3243.       begin
  3244.  
  3245.         nPos := 1;
  3246.  
  3247.         SetLength(Data, FBody.Size);
  3248.         FBody.Position := 0;
  3249.         FBody.ReadBuffer(Data[1], FBody.Size);
  3250.  
  3251.         while nPos >= 0 do
  3252.         begin
  3253.  
  3254.           DataLine(Data, DecoLine, nPos);
  3255.  
  3256.           GetMem(Buffer, 80);
  3257.           Size := DecodeLineUUCODE(TrimSpace(DecoLine), Buffer);
  3258.           FDecoded.Write(Buffer^, Size);
  3259.           FreeMem(Buffer);
  3260.         end;
  3261.  
  3262.         EncodeBinary; // Convert to base64
  3263.       end
  3264.       else
  3265.       begin
  3266.  
  3267.         GetMem(Buffer, FBody.Size);
  3268.         FBody.Position := 0;
  3269.         FBody.Read(Buffer^, FBody.Size);
  3270.         FDecoded.Write(Buffer^, FBody.Size);
  3271.         FreeMem(Buffer);
  3272.       end;
  3273.     end;
  3274.   end;
  3275. end;
  3276.  
  3277. // Encode mail part
  3278.  
  3279. procedure TMailPart.Encode(const ET: TEncodingType);
  3280. begin
  3281.  
  3282.   case ET of
  3283.  
  3284.     etBase64: EncodeBinary;
  3285.  
  3286.     etQuotedPrintable: EncodeText;
  3287.  
  3288.     etNoEncoding:
  3289.     begin
  3290.  
  3291.       FDecoded.Position := 0;
  3292.       FBody.Clear;
  3293.       FBody.LoadFromStream(FDecoded);
  3294.       SetLabelValue(_C_TE, '');
  3295.     end;
  3296.  
  3297.     et7Bit:
  3298.     begin
  3299.  
  3300.       FDecoded.Position := 0;
  3301.       FBody.Clear;
  3302.       FBody.LoadFromStream(FDecoded);
  3303.       SetLabelValue(_C_TE, '7bit');
  3304.     end;
  3305.   end;
  3306. end;
  3307.  
  3308. // Encode mail part in quoted-printable
  3309.  
  3310. procedure TMailPart.EncodeText;
  3311. var
  3312.   Buffer: String;
  3313.   Encoded: String;
  3314.  
  3315. begin
  3316.  
  3317.   FBody.Clear;
  3318.   SetLabelValue(_C_TE, 'quoted-printable');
  3319.  
  3320.   if FDecoded.Size > 0 then
  3321.   begin
  3322.  
  3323.     SetLength(Buffer, FDecoded.Size);
  3324.     FDecoded.Position := 0;
  3325.     FDecoded.ReadBuffer(Buffer[1], FDecoded.Size);
  3326.     Encoded := EncodeQuotedPrintable(Buffer, False);
  3327.     FBody.Write(Encoded[1], Length(Encoded));
  3328.   end;
  3329. end;
  3330.  
  3331. // Encode mail part in base64
  3332.  
  3333. procedure TMailPart.EncodeBinary;
  3334. begin
  3335.  
  3336.   EncodeBASE64(FBody, FDecoded);
  3337.   SetLabelValue(_C_TE, 'base64');
  3338. end;
  3339.  
  3340. { TMailPartList ============================================================== }
  3341.  
  3342. // Retrieve an item from the list
  3343.  
  3344. function TMailPartList.Get(const Index: Integer): TMailPart;
  3345. begin
  3346.  
  3347.     Result := inherited Items[Index];
  3348. end;
  3349.  
  3350. // Finalize MailPartList
  3351.  
  3352. destructor TMailPartList.Destroy;
  3353. begin
  3354.  
  3355.   inherited Destroy;
  3356. end;
  3357.  
  3358. { TMailRecipients ================================================================ }
  3359.  
  3360. // Initialize MailRecipients
  3361.  
  3362. constructor TMailRecipients.Create(MailMessage: TMailMessage2000; Field: String);
  3363. begin
  3364.  
  3365.   inherited Create;
  3366.  
  3367.   FMessage := MailMessage;
  3368.   FField := Field;
  3369.   FNames := TStringList.Create;
  3370.   FAddresses := TStringList.Create;
  3371.   FCheck := -1;
  3372. end;
  3373.  
  3374. // Finalize MailRecipients
  3375.  
  3376. destructor TMailRecipients.Destroy;
  3377. begin
  3378.  
  3379.   FNames.Free;
  3380.   FAddresses.Free;
  3381.  
  3382.   inherited Destroy;
  3383. end;
  3384.  
  3385. // Copy recipients to temporary string list
  3386.  
  3387. procedure TMailRecipients.HeaderToStrings;
  3388. var
  3389.   Dests: String;
  3390.   Loop: Integer;
  3391.   Quote: Boolean;
  3392.   IsName: Boolean;
  3393.   sName: String;
  3394.   sAddress: String;
  3395.  
  3396. begin
  3397.  
  3398.   if Length(FMessage.FHeader.Text) = FCheck then
  3399.     Exit;
  3400.  
  3401.   Dests := TrimSpace(FMessage.GetLabelValue(FField));
  3402.   FCheck := Length(FMessage.FHeader.Text);
  3403.   sName := '';
  3404.   sAddress := '';
  3405.   Quote := False;
  3406.   IsName := True;
  3407.  
  3408.   FNames.Clear;
  3409.   FAddresses.Clear;
  3410.  
  3411.   for Loop := 1 to Length(Dests) do
  3412.   begin
  3413.  
  3414.     if Dests[Loop] = '"' then
  3415.     begin
  3416.  
  3417.       Quote := not Quote;
  3418.     end
  3419.     else
  3420.     begin
  3421.  
  3422.       if (not Quote) and (Dests[Loop] in [',', ';']) then
  3423.       begin
  3424.  
  3425.         if IsName then
  3426.         begin
  3427.  
  3428.           FNames.Add('');
  3429.           FAddresses.Add(TrimSpace(sName));
  3430.         end
  3431.         else
  3432.         begin
  3433.  
  3434.           FNames.Add(DecodeLine7Bit(TrimSpace(sName)));
  3435.           FAddresses.Add(TrimSpace(sAddress));
  3436.         end;
  3437.  
  3438.         sName := '';
  3439.         sAddress := '';
  3440.         IsName := True;
  3441.       end;
  3442.  
  3443.       if IsName then
  3444.       begin
  3445.  
  3446.         if Quote then
  3447.           sName := sName + Dests[Loop]
  3448.         else
  3449.           if not (Dests[Loop] in [',', ';', '<', '>']) then
  3450.             sName := sName + Dests[Loop];
  3451.       end
  3452.       else
  3453.       begin
  3454.  
  3455.         if (not Quote) and (not (Dests[Loop] in [',', ';', '<', '>', #32])) then
  3456.           sAddress := sAddress + Dests[Loop];
  3457.       end;
  3458.  
  3459.       if (Dests[Loop] = '<') and (not Quote) then
  3460.       begin
  3461.  
  3462.         IsName := False;
  3463.       end;
  3464.     end;
  3465.   end;
  3466.  
  3467.   if Dests <> '' then
  3468.   begin
  3469.  
  3470.     if IsName then
  3471.     begin
  3472.  
  3473.       FNames.Add('');
  3474.       FAddresses.Add(TrimSpace(sName));
  3475.     end
  3476.     else
  3477.     begin
  3478.  
  3479.       FNames.Add(DecodeLine7Bit(TrimSpace(sName)));
  3480.       FAddresses.Add(TrimSpace(sAddress));
  3481.     end;
  3482.   end;
  3483. end;
  3484.  
  3485. // Replace recipients with temporary string list
  3486.  
  3487. procedure TMailRecipients.StringsToHeader;
  3488. var
  3489.   Dests: String;
  3490.   Loop: Integer;
  3491.  
  3492. begin
  3493.  
  3494.   if FAddresses.Count > 0 then
  3495.   begin
  3496.  
  3497.     Dests := '';
  3498.  
  3499.     for Loop := 0 to FAddresses.Count-1 do
  3500.     begin
  3501.  
  3502.       if TrimSpace(FNames[Loop]) <> '' then
  3503.         Dests := Dests+'"'+EncodeLine7Bit(TrimSpace(FNames[Loop]), FMessage.FCharSet)+'"'#32'<'+TrimSpace(FAddresses[Loop])+'>'
  3504.       else
  3505.         Dests := Dests+'<'+TrimSpace(FAddresses[Loop])+'>';
  3506.  
  3507.       if Loop < FAddresses.Count-1 then
  3508.         Dests := Dests+','#32;
  3509.     end;
  3510.  
  3511.     FMessage.SetLabelValue(FField, Dests);
  3512.   end
  3513.   else
  3514.   begin
  3515.  
  3516.     FMessage.SetLabelValue(FField, '');
  3517.   end;
  3518.  
  3519.   FCheck := Length(FMessage.FHeader.Text);
  3520. end;
  3521.  
  3522. // Retrieve a name by index
  3523.  
  3524. function TMailRecipients.GetName(const Index: Integer): String;
  3525. begin
  3526.  
  3527.   HeaderToStrings;
  3528.   Result := FNames[Index];
  3529. end;
  3530.  
  3531. // Retrieve a address by index
  3532.  
  3533. function TMailRecipients.GetAddress(const Index: Integer): String;
  3534. begin
  3535.  
  3536.   HeaderToStrings;
  3537.   Result := FAddresses[Index];
  3538. end;
  3539.  
  3540. // Returns number of recipients
  3541.  
  3542. function TMailRecipients.GetCount: Integer;
  3543. begin
  3544.  
  3545.   HeaderToStrings;
  3546.   Result := FAddresses.Count;
  3547. end;
  3548.  
  3549. // Replace a name by index
  3550.  
  3551. procedure TMailRecipients.SetName(const Index: Integer; const Name: String);
  3552. begin
  3553.  
  3554.   HeaderToStrings;
  3555.   FNames[Index] := Name;
  3556.   StringsToHeader;
  3557. end;
  3558.  
  3559. // Replace an address by index
  3560.  
  3561. procedure TMailRecipients.SetAddress(const Index: Integer; const Address: String);
  3562. begin
  3563.  
  3564.   HeaderToStrings;
  3565.   FAddresses[Index] := Address;
  3566.   StringsToHeader;
  3567. end;
  3568.  
  3569. // Find an recipient by name
  3570.  
  3571. function TMailRecipients.FindName(const Name: String): Integer;
  3572. begin
  3573.  
  3574.   HeaderToStrings;
  3575.   Result := SearchStringList(FNames, Name);
  3576. end;
  3577.  
  3578. // Find an recipient by address
  3579.  
  3580. function TMailRecipients.FindAddress(const Address: String): Integer;
  3581. begin
  3582.  
  3583.   HeaderToStrings;
  3584.   Result := SearchStringList(FAddresses, Address);
  3585. end;
  3586.  
  3587. // Put all names on commatext
  3588.  
  3589. function TMailRecipients.GetAllNames: String;
  3590. begin
  3591.  
  3592.   HeaderToStrings;
  3593.   Result := FNames.CommaText;
  3594. end;
  3595.  
  3596. // Put all addresses on commatext
  3597.  
  3598. function TMailRecipients.GetAllAddresses: String;
  3599. begin
  3600.  
  3601.   HeaderToStrings;
  3602.   Result := FAddresses.CommaText;
  3603. end;
  3604.  
  3605. // Set all recipients from commatext
  3606.  
  3607. procedure TMailRecipients.SetAll(const Names, Addresses: String);
  3608. begin
  3609.  
  3610.   FNames.CommaText := Names + ',';
  3611.   FAddresses.CommaText := Addresses + ',';
  3612.   FCheck := -1;
  3613.  
  3614.   while FNames.Count < FAddresses.Count do
  3615.     FNames.Add('');
  3616.  
  3617.   while FAddresses.Count < FNames.Count do
  3618.     FNames.Delete(FNames.Count-1);
  3619.  
  3620.   StringsToHeader;
  3621. end;
  3622.  
  3623. // Add recipient names to TStrings
  3624.  
  3625. procedure TMailRecipients.AddNamesTo(const Str: TStrings);
  3626. begin
  3627.  
  3628.   HeaderToStrings;
  3629.   Str.AddStrings(FNames);
  3630. end;
  3631.  
  3632. // Add recipient addresses to TStrings
  3633.  
  3634. procedure TMailRecipients.AddAddressesTo(const Str: TStrings);
  3635. begin
  3636.  
  3637.   HeaderToStrings;
  3638.   Str.AddStrings(FAddresses);
  3639. end;
  3640.  
  3641. // Add a new recipient
  3642.  
  3643. procedure TMailRecipients.Add(const Name, Address: String);
  3644. begin
  3645.  
  3646.   HeaderToStrings;
  3647.   FNames.Add(Name);
  3648.   FAddresses.Add(Address);
  3649.   StringsToHeader;
  3650. end;
  3651.  
  3652. // Replace an recipient by index
  3653.  
  3654. procedure TMailRecipients.Replace(const Index: Integer; const Name, Address: String);
  3655. begin
  3656.  
  3657.   HeaderToStrings;
  3658.   FNames[Index] := Name;
  3659.   FAddresses[Index] := Address;
  3660.   StringsToHeader;
  3661. end;
  3662.  
  3663. // Delete an recipient by index
  3664.  
  3665. procedure TMailRecipients.Delete(const Index: Integer);
  3666. begin
  3667.  
  3668.   HeaderToStrings;
  3669.   FNames.Delete(Index);
  3670.   FAddresses.Delete(Index);
  3671.   StringsToHeader;
  3672. end;
  3673.  
  3674. // Delete all recipients
  3675.  
  3676. procedure TMailRecipients.Clear;
  3677. begin
  3678.  
  3679.   FNames.Clear;
  3680.   FAddresses.Clear;
  3681.   FMessage.SetLabelValue(FField, '');
  3682.   FCheck := Length(FMessage.FHeader.Text);
  3683. end;
  3684.  
  3685. { TMailMessage2000 =============================================================== }
  3686.  
  3687. // Initialize MailMessage
  3688.  
  3689. constructor TMailMessage2000.Create(AOwner: TComponent);
  3690. begin
  3691.  
  3692.   inherited Create(AOwner);
  3693.  
  3694.   FAttachList := TMailPartList.Create;
  3695.   FTextPlain := TStringList.Create;
  3696.   FTextHTML := TStringList.Create;
  3697.   FTextPlainPart := nil;
  3698.   FTextHTMLPart := nil;
  3699.   FMixedPart := nil;
  3700.   FRelatedPart := nil;
  3701.   FAlternativePart := nil;
  3702.   FNeedRebuild := False;
  3703.   FNeedNormalize := False;
  3704.   FNeedFindParts := False;
  3705.   FCharset := _CHARSET;
  3706.   FNameCount := 0;
  3707.   FOwnerMessage := Self;
  3708.   FToList := TMailRecipients.Create(Self, 'To');
  3709.   FCcList := TMailRecipients.Create(Self, 'Cc');
  3710.   FBccList := TMailRecipients.Create(Self, 'Bcc');
  3711.   FTextEncoding := etQuotedPrintable;
  3712. end;
  3713.  
  3714. // Finalize MailMessage
  3715.  
  3716. destructor TMailMessage2000.Destroy;
  3717. begin
  3718.  
  3719.   inherited Destroy;
  3720.  
  3721.   FAttachList.Free;
  3722.   FTextPlain.Free;
  3723.   FTextHTML.Free;
  3724.   FToList.Free;
  3725.   FCcList.Free;
  3726.   FBccList.Free;
  3727. end;
  3728.  
  3729. // Get a dest. name from a field
  3730.  
  3731. function TMailMessage2000.GetDestName(Field: String; const Index: Integer): String;
  3732. var
  3733.   Dests: String;
  3734.   Loop: Integer;
  3735.   Count: Integer;
  3736.   Quote: Boolean;
  3737.   Name: String;
  3738.  
  3739. begin
  3740.  
  3741.   Dests := TrimSpace(GetLabelValue(Field));
  3742.   Count := 0;
  3743.   Name := '';
  3744.   Quote := False;
  3745.  
  3746.   for Loop := 1 to Length(Dests) do
  3747.   begin
  3748.  
  3749.     if Dests[Loop] = '"' then
  3750.     begin
  3751.  
  3752.       Quote := not Quote;
  3753.     end
  3754.     else
  3755.     begin
  3756.  
  3757.       if (not Quote) and (Dests[Loop] in [',', ';']) then Inc(Count);
  3758.  
  3759.       if Count > Index then
  3760.       begin
  3761.  
  3762.         Name := '';
  3763.         Break;
  3764.       end;
  3765.  
  3766.       if Count = Index then
  3767.       begin
  3768.  
  3769.         if (Dests[Loop] = '<') and (not Quote) then
  3770.         begin
  3771.  
  3772.           Break;
  3773.         end
  3774.         else
  3775.         begin
  3776.  
  3777.           if Quote or (not (Dests[Loop] in [',', ';'])) then
  3778.             Name := Name + Dests[Loop];
  3779.         end;
  3780.       end;
  3781.     end;
  3782.  
  3783.     if Loop = Length(Dests) then Name := '';
  3784.   end;
  3785.  
  3786.   Result := DecodeLine7Bit(TrimSpace(Name));
  3787. end;
  3788.  
  3789. // Get a dest. address from a field
  3790.  
  3791. function TMailMessage2000.GetDestAddress(Field: String; const Index: Integer): String;
  3792. var
  3793.   Dests: String;
  3794.   Loop: Integer;
  3795.   Count: Integer;
  3796.   Quote: Boolean;
  3797.   Address: String;
  3798.  
  3799. begin
  3800.  
  3801.   Dests := TrimSpace(GetLabelValue(Field));
  3802.   Count := 0;
  3803.   Address := '';
  3804.   Quote := False;
  3805.  
  3806.   for Loop := 1 to Length(Dests) do
  3807.   begin
  3808.  
  3809.     if Dests[Loop] = '"' then
  3810.     begin
  3811.  
  3812.       Quote := not Quote;
  3813.     end
  3814.     else
  3815.     begin
  3816.  
  3817.       if (not Quote) and (Dests[Loop] in [',', ';']) then Inc(Count);
  3818.  
  3819.       if Count > Index then Break;
  3820.  
  3821.       if Count = Index then
  3822.       begin
  3823.  
  3824.         if (not Quote) and (not (Dests[Loop] in [',', ';', '<', '>', #32])) then
  3825.           Address := Address + Dests[Loop];
  3826.  
  3827.         if (Dests[Loop] = '<') and (not Quote) then
  3828.         begin
  3829.  
  3830.           Address := '';
  3831.         end;
  3832.  
  3833.         if (Dests[Loop] = '>') and (not Quote) then
  3834.         begin
  3835.  
  3836.           Break;
  3837.         end;
  3838.       end;
  3839.     end;
  3840.   end;
  3841.  
  3842.   Result := TrimSpace(Address);
  3843. end;
  3844.  
  3845. // Count the instances of 'Received' fields in header
  3846.  
  3847. function TMailMessage2000.GetReceivedCount: Integer;
  3848. begin
  3849.  
  3850.   Result := 0;
  3851.  
  3852.   while SearchStringList(FHeader, 'Received:', Result) >= 0 do
  3853.     Inc(Result);
  3854. end;
  3855.  
  3856. // Retrieve a 'Received' field
  3857.  
  3858. function TMailMessage2000.GetReceived(const Index: Integer): TReceived;
  3859. var
  3860.   Dests: String;
  3861.   Loop: Integer;
  3862.   Quote: Integer;
  3863.   Value: String;
  3864.   Field: TReceivedField;
  3865.  
  3866. begin
  3867.  
  3868.   Result.From := '';
  3869.   Result.By := '';
  3870.   Result.Address := '';
  3871.   Result.Date := 0;
  3872.  
  3873.   Dests := Trim(Copy(FHeader[SearchStringList(FHeader, 'Received', Index)], 10, 9999))+#1;
  3874.   Value := '';
  3875.   Field := reNone;
  3876.   Quote := 0;
  3877.  
  3878.   for Loop := 1 to Length(Dests) do
  3879.   begin
  3880.  
  3881.     if Dests[Loop] in ['(', '['] then
  3882.       Inc(Quote);
  3883.  
  3884.     if Dests[Loop] in [')', ']'] then
  3885.       Dec(Quote);
  3886.  
  3887.     if Quote < 0 then
  3888.       Quote := 0;
  3889.  
  3890.     if (not (Dests[Loop] in ['"', '<', '>', #39, ')', ']'])) and (Quote = 0) then
  3891.     begin
  3892.  
  3893.       if (Dests[Loop] = #32) and (Field = reNone) then
  3894.       begin
  3895.  
  3896.         if LowerCase(Trim(Value)) = 'from' then
  3897.           Field := reFrom;
  3898.  
  3899.         if LowerCase(Trim(Value)) = 'by' then
  3900.           Field := reBy;
  3901.  
  3902.         if LowerCase(Trim(Value)) = 'for' then
  3903.           Field := reFor;
  3904.  
  3905.         Value := '';
  3906.       end;
  3907.  
  3908.       if Dests[Loop] in [#32, ';'] then
  3909.       begin
  3910.  
  3911.         if (Trim(Value) <> '') and (Field in [reFrom, reBy, reFor]) then
  3912.         begin
  3913.  
  3914.           case Field of
  3915.  
  3916.             reFrom: Result.From := Trim(Value);
  3917.  
  3918.             reBy: Result.By := Trim(Value);
  3919.  
  3920.             reFor: Result.Address := Trim(Value);
  3921.           end;
  3922.  
  3923.           Value := '';
  3924.           Field := reNone;
  3925.         end;
  3926.       end;
  3927.  
  3928.       if not (Dests[Loop] in [#32, ';']) then
  3929.       begin
  3930.  
  3931.         Value := Value + Dests[Loop];
  3932.       end;
  3933.  
  3934.       if Dests[Loop] = ';' then
  3935.       begin
  3936.  
  3937.         Value := Copy(Dests, Loop+1, Length(Dests));
  3938.         Result.Date := MailDateToDelphiDate(Trim(Value));
  3939.         Break;
  3940.       end;
  3941.     end;
  3942.   end;
  3943. end;
  3944.  
  3945. // Add a 'Received:' in message header
  3946.  
  3947. procedure TMailMessage2000.AddHop(const From, By, Aplic, Address: String);
  3948. var
  3949.   Text: String;
  3950.  
  3951. begin
  3952.  
  3953.   Text := 'Received:';
  3954.  
  3955.   if From <> '' then
  3956.     Text := Text + #32'from'#32+From;
  3957.  
  3958.   if By <> '' then
  3959.     Text := Text + #32'by'#32+By;
  3960.  
  3961.   if Aplic <> '' then
  3962.     Text := Text + #32'with'#32+Aplic;
  3963.  
  3964.   if Address <> '' then
  3965.     Text := Text + #32'for'#32'<'+Address+'>';
  3966.  
  3967.   Text := Text + ';'#32+DelphiDateToMailDate(Now);
  3968.  
  3969.   FHeader.Insert(0, Text);
  3970. end;
  3971.  
  3972. // Get the From: name
  3973.  
  3974. function TMailMessage2000.GetFromName: String;
  3975. begin
  3976.  
  3977.   Result := GetDestName(_FFR, 0);
  3978. end;
  3979.  
  3980. // Get the From: address
  3981.  
  3982. function TMailMessage2000.GetFromAddress: String;
  3983. begin
  3984.  
  3985.   Result := GetDestAddress(_FFR, 0);
  3986. end;
  3987.  
  3988. // Get the Reply-To: name
  3989.  
  3990. function TMailMessage2000.GetReplyToName: String;
  3991. begin
  3992.  
  3993.   Result := GetDestName(_FRT, 0);
  3994. end;
  3995.  
  3996. // Get the Reply-To: address
  3997.  
  3998. function TMailMessage2000.GetReplyToAddress: String;
  3999. begin
  4000.  
  4001.   Result := GetDestAddress(_FRT, 0);
  4002. end;
  4003.  
  4004. // Set the From: name/address
  4005.  
  4006. procedure TMailMessage2000.SetFrom(const Name, Address: String);
  4007. begin
  4008.  
  4009.   if (Name <> '') and (Address <> '') then
  4010.     SetLabelValue(_FFR, '"' + EncodeLine7Bit(Name, FCharset) + '" <' + Address + '>')
  4011.   else
  4012.     if Address <> '' then
  4013.       SetLabelValue(_FFR, '<' + Address + '>')
  4014.     else
  4015.       SetLabelValue(_FFR, '');
  4016. end;
  4017.  
  4018. // Set the Reply-To: name/address
  4019.  
  4020. procedure TMailMessage2000.SetReplyTo(const Name, Address: String);
  4021. begin
  4022.  
  4023.   if (Name <> '') and (Address <> '') then
  4024.     SetLabelValue(_FRT, '"' + EncodeLine7Bit(Name, FCharset) + '" <' + Address + '>')
  4025.   else
  4026.     if Address <> '' then
  4027.       SetLabelValue(_FRT, '<' + Address + '>')
  4028.     else
  4029.       SetLabelValue(_FRT, '');
  4030. end;
  4031.  
  4032. // Get the subject
  4033.  
  4034. function TMailMessage2000.GetSubject: String;
  4035. begin
  4036.  
  4037.   Result := DecodeLine7Bit(GetLabelValue('Subject'));
  4038. end;
  4039.  
  4040. // Set the subject
  4041.  
  4042. procedure TMailMessage2000.SetSubject(const Subject: String);
  4043. begin
  4044.  
  4045.   SetLabelValue('Subject', EncodeLine7Bit(Subject, FCharset))
  4046. end;
  4047.  
  4048. // Get the date in TDateTime format
  4049.  
  4050. function TMailMessage2000.GetDate: TDateTime;
  4051. begin
  4052.  
  4053.   Result := MailDateToDelphiDate(TrimSpace(GetLabelValue('Date')));
  4054. end;
  4055.  
  4056. // Set the date in RFC822 format
  4057.  
  4058. procedure TMailMessage2000.SetDate(const Date: TDateTime);
  4059. begin
  4060.  
  4061.   SetLabelValue('Date', DelphiDateToMailDate(Date));
  4062. end;
  4063.  
  4064. // Get message id
  4065.  
  4066. function TMailMessage2000.GetMessageId: String;
  4067. begin
  4068.  
  4069.   Result := GetLabelValue(_M_ID);
  4070. end;
  4071.  
  4072. // Set a unique message id (the parameter is just the host)
  4073.  
  4074. procedure TMailMessage2000.SetMessageId(const MessageId: String);
  4075. var
  4076.   IDStr: String;
  4077.  
  4078. begin
  4079.  
  4080.   IDStr := '<'+FormatDateTime('yyyymmddhhnnss', Now)+'.'+TrimSpace(Format('%8x', [Random($FFFFFFFF)]))+'.'+TrimSpace(Format('%8x', [Random($FFFFFFFF)]))+'@'+MessageId+'>';
  4081.  
  4082.   SetLabelValue(_M_ID, IDStr);
  4083. end;
  4084.  
  4085. // Searches for attached files and determines AttachList, TextPlain, TextHTML.
  4086.  
  4087. procedure TMailMessage2000.FindParts;
  4088.  
  4089.   function GetPart(Part: TMailPart): Boolean;
  4090.  
  4091.     function GetText(Info: String): Boolean;
  4092.     var
  4093.       Buffer: PChar;
  4094.  
  4095.     begin
  4096.  
  4097.       Result := False;
  4098.  
  4099.       if (FTextPlainPart = nil) and (Info = _T_P) then
  4100.       begin
  4101.  
  4102.         if Part.Decode and (Part.Decoded.Size > 0) then
  4103.         begin
  4104.  
  4105.           FTextPlainPart := Part;
  4106.  
  4107.           GetMem(Buffer, Part.FDecoded.Size+1);
  4108.           StrLCopy(Buffer, Part.FDecoded.Memory, Part.FDecoded.Size);
  4109.           Buffer[Part.FDecoded.Size] := #0;
  4110.           FTextPlain.SetText(Buffer);
  4111.           FreeMem(Buffer);
  4112.  
  4113.           Result := True;
  4114.         end;
  4115.       end;
  4116.  
  4117.       if (FTextHTMLPart = nil) and (Info = _T_H) then
  4118.       begin
  4119.  
  4120.         if Part.Decode and (Part.Decoded.Size > 0) then
  4121.         begin
  4122.  
  4123.           FTextHTMLPart := Part;
  4124.  
  4125.           GetMem(Buffer, Part.FDecoded.Size+1);
  4126.           StrLCopy(Buffer, Part.FDecoded.Memory, Part.FDecoded.Size);
  4127.           Buffer[Part.FDecoded.Size] := #0;
  4128.           FTextHTML.SetText(Buffer);
  4129.           FreeMem(Buffer);
  4130.  
  4131.           Result := True;
  4132.         end;
  4133.       end;
  4134.     end;
  4135.  
  4136.   begin
  4137.  
  4138.     Result := True;
  4139.  
  4140.     // Check for multipart/mixed
  4141.  
  4142.     if (FMixedPart = nil) and (Part.GetAttachInfo = _M_M) then
  4143.     begin
  4144.  
  4145.       FMixedPart := Part;
  4146.       Exit;
  4147.     end;
  4148.  
  4149.     // Check for multipart/related
  4150.  
  4151.     if (FRelatedPart = nil) and (Part.GetAttachInfo = _M_R) then
  4152.     begin
  4153.  
  4154.       FRelatedPart := Part;
  4155.       Exit;
  4156.     end;
  4157.  
  4158.     // Check for multipart/alternative
  4159.  
  4160.     if (FAlternativePart = nil) and (Part.GetAttachInfo = _M_A) then
  4161.     begin
  4162.  
  4163.       FAlternativePart := Part;
  4164.       Exit;
  4165.     end;
  4166.  
  4167.     // Check for texts (when message is only one text)
  4168.  
  4169.     if (Part = Self) and (Copy(Part.GetAttachInfo, 1, Length(_TXT)) = _TXT) and (FSubPartList.Count = 0) then
  4170.     begin
  4171.  
  4172.       if GetText(Part.GetAttachInfo) then
  4173.         Exit;
  4174.     end;
  4175.  
  4176.     // Check for texts (when message is only one text - no mime info)
  4177.  
  4178.     if (Part = Self) and (Part.GetAttachInfo = '') and (FSubPartList.Count = 0) then
  4179.     begin
  4180.  
  4181.       if GetText(_T_P) then
  4182.         Exit;
  4183.     end;
  4184.  
  4185.     // Check for texts (when message has one text plus attachs)
  4186.  
  4187.     if (FMixedPart <> nil) and (Part.FOwnerPart = FMixedPart) and (FAlternativePart = nil) then
  4188.     begin
  4189.  
  4190.       if GetText(Part.GetAttachInfo) then
  4191.         Exit;
  4192.     end;
  4193.  
  4194.     // Check for texts (when message one text with embedded)
  4195.  
  4196.     if (FRelatedPart <> nil) and (Part.FOwnerPart = FRelatedPart) then
  4197.     begin
  4198.  
  4199.       if GetText(Part.GetAttachInfo) then
  4200.         Exit;
  4201.     end;
  4202.  
  4203.     // Check for texts (when message has alternative texts)
  4204.  
  4205.     if (FAlternativePart <> nil) and (Part.FOwnerPart = FAlternativePart) then
  4206.     begin
  4207.  
  4208.       if GetText(Part.GetAttachInfo) then
  4209.         Exit;
  4210.     end;
  4211.  
  4212.     // If everything else failed, assume attachment
  4213.  
  4214.     if Part.FSubPartList.Count = 0 {Copy(Part.GetAttachInfo, 1, Length(_MP)) <> _MP} then
  4215.     begin
  4216.  
  4217.       Part.FEmbedded := Part.FOwnerPart = FRelatedPart;
  4218.       FAttachList.Add(Part);
  4219.     end;
  4220.   end;
  4221.  
  4222.   procedure DecodeRec(MP: TMailPart);
  4223.   var
  4224.     Loop: Integer;
  4225.  
  4226.   begin
  4227.  
  4228.     if GetPart(MP) then
  4229.     begin
  4230.  
  4231.       for Loop := 0 to MP.FSubPartList.Count-1 do
  4232.       begin
  4233.  
  4234.         DecodeRec(MP.FSubPartList[Loop]);
  4235.       end;
  4236.     end;
  4237.   end;
  4238.  
  4239. begin
  4240.  
  4241.   if not FNeedFindParts then
  4242.     Exit;
  4243.  
  4244.   FAttachList.Clear;
  4245.   FTextPlainPart := nil;
  4246.   FTextHTMLPart := nil;
  4247.   FMixedPart := nil;
  4248.   FRelatedPart := nil;
  4249.   FAlternativePart := nil;
  4250.   FTextPlain.Clear;
  4251.   FTextHTML.Clear;
  4252.   FNeedFindParts := False;
  4253.  
  4254.   DecodeRec(Self);
  4255. end;
  4256.  
  4257. // Ajust parts to the Mail2000 standards
  4258.  
  4259. procedure TMailMessage2000.Normalize(const Kind: TNormalizer = nrFirst);
  4260. var
  4261.   nLoop, nOcor: Integer;
  4262.   SaveBody, TmpPart, TmpMixed, TmpRelated, TmpAlternative: TMailPart;
  4263.   Ext, FName: String;
  4264.   nTexts, nAttachs, nEmbedded: Integer;
  4265.  
  4266.   procedure CreateMixed(Father: TMailPart);
  4267.   begin
  4268.  
  4269.     if Father = nil then
  4270.     begin
  4271.  
  4272.       SetLabelValue(_C_T, _M_M);
  4273.       SetLabelParamValue(_C_T, _BDRY, '"'+GenerateBoundary+'_mixed"');
  4274.       TmpMixed := Self;
  4275.     end
  4276.     else
  4277.     begin
  4278.  
  4279.       TmpMixed := TMailPart.Create(Self);
  4280.       TmpMixed.FOwnerMessage := Self;
  4281.       TmpMixed.FOwnerPart := Father;
  4282.       TmpMixed.FParentBoundary := Father.GetBoundary;
  4283.       TmpMixed.SetLabelValue(_C_T, _M_R);
  4284.       TmpMixed.SetLabelParamValue(_C_T, _BDRY, '"'+GenerateBoundary+'_Mixed"');
  4285.       Father.FSubPartList.Add(TmpMixed);
  4286.     end;
  4287.   end;
  4288.  
  4289.   procedure CreateRelated(Father: TMailPart);
  4290.   begin
  4291.  
  4292.     if Father = nil then
  4293.     begin
  4294.  
  4295.       SetLabelValue(_C_T, _M_R);
  4296.       SetLabelParamValue(_C_T, _BDRY, '"'+GenerateBoundary+'_related"');
  4297.       TmpRelated := Self;
  4298.     end
  4299.     else
  4300.     begin
  4301.  
  4302.       TmpRelated := TMailPart.Create(Self);
  4303.       TmpRelated.FOwnerMessage := Self;
  4304.       TmpRelated.FOwnerPart := Father;
  4305.       TmpRelated.FParentBoundary := Father.GetBoundary;
  4306.       TmpRelated.SetLabelValue(_C_T, _M_R);
  4307.       TmpRelated.SetLabelParamValue(_C_T, _BDRY, '"'+GenerateBoundary+'_related"');
  4308.       Father.FSubPartList.Add(TmpRelated);
  4309.     end;
  4310.   end;
  4311.  
  4312.   procedure CreateAlternative(Father: TMailPart);
  4313.   begin
  4314.  
  4315.     if Father = nil then
  4316.     begin
  4317.  
  4318.       SetLabelValue(_C_T, _M_A);
  4319.       SetLabelParamValue(_C_T, _BDRY, '"'+GenerateBoundary+'_alternative"');
  4320.       TmpAlternative := Self;
  4321.     end
  4322.     else
  4323.     begin
  4324.  
  4325.       TmpAlternative := TMailPart.Create(Self);
  4326.       TmpAlternative.FOwnerMessage := Self;
  4327.       TmpAlternative.FOwnerPart := Father;
  4328.       TmpAlternative.FParentBoundary := Father.GetBoundary;
  4329.       TmpAlternative.SetLabelValue(_C_T, _M_A);
  4330.       TmpAlternative.SetLabelParamValue(_C_T, _BDRY, '"'+GenerateBoundary+'_alternative"');
  4331.       Father.FSubPartList.Add(TmpAlternative);
  4332.     end;
  4333.   end;
  4334.  
  4335.   procedure CreateTextPlain(Father: TMailPart);
  4336.   begin
  4337.  
  4338.     FTextPlainPart.Remove;
  4339.  
  4340.     if Father = nil then
  4341.     begin
  4342.  
  4343.       SetLabelValue(_C_T, _T_P);
  4344.       SetLabelValue(_C_D, _INLN);
  4345.       FTextPlainPart.Decode;
  4346.       FTextPlainPart.FDecoded.Position := 0;
  4347.       FDecoded.LoadFromStream(FTextPlainPart.FDecoded);
  4348.       Encode(FTextEncoding);
  4349.       FTextPlainPart.Free;
  4350.       FTextPlainPart := Self;
  4351.     end
  4352.     else
  4353.     begin
  4354.  
  4355.       FTextPlainPart.FOwnerPart := Father;
  4356.       FTextPlainPart.FParentBoundary := Father.GetBoundary;
  4357.       FTextPlainPart.SetLabelValue(_C_T, _T_P);
  4358.       FTextPlainPart.SetLabelValue(_C_D, _INLN);
  4359.       FTextPlainPart.Decode;
  4360.       FTextPlainPart.Encode(FTextEncoding);
  4361.       FTextPlainPart.SetLabelValue(_C_L, IntToStr(FTextPlainPart.FBody.Size));
  4362.       FTextPlainPart.FSubPartList.Clear;
  4363.       Father.FSubPartList.Add(FTextPlainPart);
  4364.     end;
  4365.   end;
  4366.  
  4367.   procedure CreateTextHTML(Father: TMailPart);
  4368.   begin
  4369.  
  4370.     FTextHTMLPart.Remove;
  4371.  
  4372.     if Father = nil then
  4373.     begin
  4374.  
  4375.       SetLabelValue(_C_T, _T_H);
  4376.       SetLabelValue(_C_D, _INLN);
  4377.       FTextHTMLPart.Decode;
  4378.       FTextHTMLPart.FDecoded.Position := 0;
  4379.       FDecoded.LoadFromStream(FTextHTMLPart.FDecoded);
  4380.       Encode(FTextEncoding);
  4381.       FTextHTMLPart.Free;
  4382.       FTextHTMLPart := Self;
  4383.     end
  4384.     else
  4385.     begin
  4386.  
  4387.       FTextHTMLPart.FOwnerPart := Father;
  4388.       FTextHTMLPart.FParentBoundary := Father.GetBoundary;
  4389.       FTextHTMLPart.SetLabelValue(_C_T, _T_H);
  4390.       FTextHTMLPart.SetLabelValue(_C_D, _INLN);
  4391.       FTextHTMLPart.Decode;
  4392.       FTextHTMLPart.Encode(FTextEncoding);
  4393.       FTextHTMLPart.SetLabelValue(_C_L, IntToStr(FTextHTMLPart.FBody.Size));
  4394.       FTextHTMLPart.FSubPartList.Clear;
  4395.       Father.FSubPartList.Add(FTextHTMLPart);
  4396.     end;
  4397.   end;
  4398.  
  4399.   procedure CreateAttachment(var Part: TMailPart; Father: TMailPart);
  4400.   begin
  4401.  
  4402.     Part.Remove;
  4403.  
  4404.     if Part.GetLabelValue(_C_T) = '' then
  4405.     begin
  4406.  
  4407.       Part.SetLabelValue(_C_T, _A_OS);
  4408.     end;
  4409.  
  4410.     Ext := GetMimeExtension(Part.GetLabelValue(_C_T));
  4411.  
  4412.     if (Part.GetLabelParamValue(_C_T, 'name') = '') then
  4413.     begin
  4414.  
  4415.       Part.SetLabelParamValue(_C_T, 'name', '"file_'+IntToStr(FNameCount)+Ext+'"');
  4416.       Inc(FNameCount);
  4417.     end;
  4418.  
  4419.     FName := Part.GetLabelParamValue(_C_T, 'name');
  4420.  
  4421.     if (Part.GetLabelParamValue(_C_D, 'filename') = '') then
  4422.     begin
  4423.  
  4424.       Part.SetLabelParamValue(_C_D, 'filename', '"'+FName+'"');
  4425.     end;
  4426.  
  4427.     if Part.FEmbedded then
  4428.     begin
  4429.  
  4430.       if Part.GetLabelValue(_C_ID) = '' then
  4431.         Part.SetLabelValue(_C_ID, FName);
  4432.  
  4433.       Part.SetLabelValue(_C_D, _INLN);
  4434.       Part.FOwnerPart := TmpRelated;
  4435.       Part.FParentBoundary := TmpRelated.GetBoundary;
  4436.       TmpRelated.FSubPartList.Add(Part);
  4437.     end
  4438.     else
  4439.     begin
  4440.  
  4441.       if Father <> nil then
  4442.       begin
  4443.  
  4444.         Part.SetLabelValue(_C_D, _ATCH);
  4445.         Part.FOwnerPart := Father;
  4446.         Part.FParentBoundary := Father.GetBoundary;
  4447.         Father.FSubPartList.Add(Part);
  4448.       end
  4449.       else
  4450.       begin
  4451.  
  4452.         nOcor := 0;
  4453.  
  4454.         repeat
  4455.         begin
  4456.  
  4457.           nLoop := SearchStringList(Part.FHeader, _CONT, nOcor);
  4458.           Inc(nOcor);
  4459.           if nLoop >= 0 then
  4460.             FHeader.Add(Part.FHeader[nLoop]);
  4461.         end
  4462.         until nLoop < 0;
  4463.  
  4464.         Part.FDecoded.Position := 0;
  4465.         FDecoded.LoadFromStream(Part.FDecoded);
  4466.         Encode(etBase64);
  4467.         FAttachList.Delete(FAttachList.IndexOf(Part));
  4468.         FAttachList.Add(Self);
  4469.         Part.Free;
  4470.       end;
  4471.     end;
  4472.   end;
  4473.  
  4474. begin
  4475.  
  4476.   if (not FNeedNormalize) and (Kind = nrFirst) then
  4477.     Exit;
  4478.  
  4479.   FindParts;
  4480.  
  4481.   FNeedRebuild := True;
  4482.   FNeedNormalize := False;
  4483.   FNameCount := 0;
  4484.   nTexts := 0;
  4485.   nAttachs := 0;
  4486.   nEmbedded := 0;
  4487.  
  4488.   // What content has this mail?
  4489.  
  4490.   case Kind of
  4491.  
  4492.     nrAddText: Inc(nTexts);
  4493.     nrAddAttach: Inc(nAttachs);
  4494.     nrAddEmbedded: Inc(nEmbedded);
  4495.   end;
  4496.  
  4497.   if FTextPlainPart <> nil then
  4498.     Inc(nTexts);
  4499.  
  4500.   if FTextHTMLPart <> nil then
  4501.     Inc(nTexts);
  4502.  
  4503.   for nLoop := 0 to FAttachList.Count-1 do
  4504.     if FAttachList[nLoop].FEmbedded then
  4505.       Inc(nEmbedded)
  4506.     else
  4507.       Inc(nAttachs);
  4508.  
  4509.   // Save current main body
  4510.  
  4511.   if (FBody.Size > 0) then
  4512.   begin
  4513.  
  4514.     SaveBody := TMailPart.Create(Self);
  4515.     SaveBody.FBody.LoadFromStream(FBody);
  4516.     SaveBody.FOwnerMessage := Self;
  4517.  
  4518.     // Copy content fields from main header
  4519.  
  4520.     nOcor := 0;
  4521.  
  4522.     repeat
  4523.     begin
  4524.  
  4525.       nLoop := SearchStringList(FHeader, _CONT, nOcor);
  4526.       Inc(nOcor);
  4527.       if nLoop >= 0 then
  4528.         SaveBody.FHeader.Add(FHeader[nLoop]);
  4529.     end
  4530.     until nLoop < 0;
  4531.  
  4532.     // Classify main body
  4533.  
  4534.     if Self = FTextPlainPart then
  4535.       FTextPlainPart := SaveBody
  4536.     else
  4537.       if Self = FTextHTMLPart then
  4538.         FTextHTMLPart := SaveBody
  4539.       else
  4540.         if Self = FMixedPart then
  4541.           FMixedPart := SaveBody
  4542.         else
  4543.           if Self = FRelatedPart then
  4544.             FRelatedPart := SaveBody
  4545.           else
  4546.             if Self = FAlternativePart then
  4547.               FAlternativePart := SaveBody
  4548.             else
  4549.               if (FSubPartList.Count = 0) then
  4550.                 FAttachList.Add(SaveBody)
  4551.               else
  4552.                 SaveBody.Free;
  4553.   end;
  4554.  
  4555.   // If entire mail is an attach, remove from list.
  4556.  
  4557.   if FAttachList.IndexOf(Self) >= 0 then
  4558.     FAttachList.Delete(FAttachList.IndexOf(Self));
  4559.  
  4560.   // Create new multiparts
  4561.  
  4562.   SetLabelValue(_C_T, '');
  4563.   SetLabelValue(_C_TE, '');
  4564.   SetLabelValue(_C_D, '');
  4565.   SetLabelValue(_C_ID, '');
  4566.   SetLabelValue(_C_L, '');
  4567.   SetLabelValue(_M_V, '1.0');
  4568.   SetLabelValue(_X_M, _XMailer);
  4569.  
  4570.   TmpMixed := nil;
  4571.   TmpRelated := nil;
  4572.   TmpAlternative := nil;
  4573.   FTextFather := nil;
  4574.  
  4575.   // There are more than one attachment?
  4576.  
  4577.   if nAttachs > 1 then
  4578.   begin
  4579.  
  4580.     CreateMixed(nil);
  4581.     FTextFather := TmpMixed;
  4582.   end;
  4583.  
  4584.   // There are texts plus attachments?
  4585.  
  4586.   if (nAttachs > 0) and (nTexts > 0) then
  4587.   begin
  4588.  
  4589.     CreateMixed(nil);
  4590.     FTextFather := TmpMixed;
  4591.   end;
  4592.  
  4593.   // There are attachments and embedded attachments?
  4594.  
  4595.   if (nAttachs > 0) and (nEmbedded > 0) then
  4596.   begin
  4597.  
  4598.     CreateMixed(nil);
  4599.     FTextFather := TmpMixed;
  4600.   end;
  4601.  
  4602.   // There are embedded attachments?
  4603.  
  4604.   if nEmbedded > 0 then
  4605.   begin
  4606.  
  4607.     CreateRelated(TmpMixed);
  4608.     FTextFather := TmpRelated;
  4609.   end;
  4610.  
  4611.   // There are more than one text?
  4612.  
  4613.   if nTexts > 1 then
  4614.   begin
  4615.  
  4616.     CreateAlternative(FTextFather);
  4617.     FTextFather := TmpAlternative;
  4618.   end;
  4619.  
  4620.   // Normalize text parts
  4621.  
  4622.   if FTextPlainPart <> nil then
  4623.     CreateTextPlain(FTextFather);
  4624.  
  4625.   if FTextHTMLPart <> nil then
  4626.     CreateTextHTML(FTextFather);
  4627.  
  4628.   // Normalize attachments
  4629.  
  4630.   for nLoop := 0 to FAttachList.Count-1 do
  4631.   begin
  4632.  
  4633.     TmpPart := FAttachList[nLoop];
  4634.     CreateAttachment(TmpPart, TmpMixed);
  4635.   end;
  4636.  
  4637.   // Remove old multiparts
  4638.  
  4639.   if (FAlternativePart <> nil) and (FAlternativePart <> Self) then
  4640.   begin
  4641.  
  4642.     FAlternativePart.Remove;
  4643.     FAlternativePart.Free;
  4644.   end;
  4645.  
  4646.   if (FRelatedPart <> nil) and (FRelatedPart <> Self) then
  4647.   begin
  4648.  
  4649.     FRelatedPart.Remove;
  4650.     FRelatedPart.Free;
  4651.   end;
  4652.  
  4653.   if (FMixedPart <> nil) and (FMixedPart <> Self) then
  4654.   begin
  4655.  
  4656.     FMixedPart.Remove;
  4657.     FMixedPart.Free;
  4658.   end;
  4659.  
  4660.   FMixedPart := TmpMixed;
  4661.   FRelatedPart := TmpRelated;
  4662.   FAlternativePart := TmpAlternative;
  4663. end;
  4664.  
  4665. // Insert a text on message
  4666.  
  4667. procedure TMailMessage2000.PutText(Text: String; var Part: TMailPart; Content: String);
  4668. begin
  4669.  
  4670.   if Part = nil then
  4671.     Normalize(nrAddText)
  4672.   else
  4673.     Normalize(nrFirst);
  4674.  
  4675.   Text := AdjustLineBreaks(Text);
  4676.  
  4677.   if Part = nil then
  4678.   begin
  4679.  
  4680.     if FTextFather <> nil then
  4681.     begin
  4682.  
  4683.       Part := TMailPart.Create(Self);
  4684.       Part.FOwnerPart := FTextFather;
  4685.       Part.FOwnerMessage := Self.FOwnerMessage;
  4686.       Part.FParentBoundary := FTextFather.GetBoundary;
  4687.       FTextFather.FSubPartList.Add(Part);
  4688.     end
  4689.     else
  4690.     begin
  4691.  
  4692.       Part := Self;
  4693.     end;
  4694.   end;
  4695.  
  4696.   Part.Decoded.Clear;
  4697.   Part.Decoded.Write(Text[1], Length(Text));
  4698.   Part.Encode(FTextEncoding);
  4699.  
  4700.   Part.SetLabelValue(_C_T, Content);
  4701.   Part.SetLabelParamValue(_C_T, 'charset', '"'+FCharset+'"');
  4702.   Part.SetLabelValue(_C_D, _INLN);
  4703.   Part.SetLabelValue(_C_L, IntToStr(Part.FBody.Size));
  4704.  
  4705.   FNeedRebuild := True;
  4706. end;
  4707.  
  4708. // Remove a text from message
  4709.  
  4710. procedure TMailMessage2000.RemoveText(var Part: TMailPart);
  4711. begin
  4712.  
  4713.   Normalize(nrFirst);
  4714.  
  4715.   if Part <> nil then
  4716.   begin
  4717.  
  4718.     if Part <> Self then
  4719.     begin
  4720.  
  4721.       Part.Remove;
  4722.       Part.Free;
  4723.     end
  4724.     else
  4725.     begin
  4726.  
  4727.       FBody.Clear;
  4728.       FDecoded.Clear;
  4729.       SetLabelValue(_C_T, '');
  4730.       SetLabelValue(_C_TE, '');
  4731.       SetLabelValue(_C_D, '');
  4732.       SetLabelValue(_C_L, '');
  4733.     end;
  4734.   end;
  4735.  
  4736.   Part := nil;
  4737.   Normalize(nrForce);
  4738.   FNeedRebuild := True;
  4739. end;
  4740.  
  4741. // Replace or create a mailpart for text/plain
  4742.  
  4743. procedure TMailMessage2000.SetTextPlain(const Text: String);
  4744. begin
  4745.  
  4746.   PutText(Text, FTextPlainPart, _T_P);
  4747.   FTextPlain.Text := Text;
  4748. end;
  4749.  
  4750. // Replace or create a mailpart for text/html
  4751.  
  4752. procedure TMailMessage2000.SetTextHTML(const Text: String);
  4753. begin
  4754.  
  4755.   PutText(Text, FTextHTMLPart, _T_H);
  4756.   FTextHTML.Text := Text;
  4757. end;
  4758.  
  4759. // Remove text/plain mailpart
  4760.  
  4761. procedure TMailMessage2000.RemoveTextPlain;
  4762. begin
  4763.  
  4764.   if FTextPlainPart <> nil then
  4765.   begin
  4766.  
  4767.     RemoveText(FTextPlainPart);
  4768.     FTextPlain.Clear;
  4769.   end;
  4770. end;
  4771.  
  4772. // Remove text/html mailpart
  4773.  
  4774. procedure TMailMessage2000.RemoveTextHTML;
  4775. begin
  4776.  
  4777.   if FTextHTMLPart <> nil then
  4778.   begin
  4779.  
  4780.     RemoveText(FTextHTMLPart);
  4781.     FTextHTML.Clear;
  4782.   end;
  4783. end;
  4784.  
  4785. // Create a mailpart and encode the file
  4786.  
  4787. procedure TMailMessage2000.AttachFile(const FileName: String; const ContentType: String = ''; const EncodingType: TEncodingType = etBase64; const IsEmbedded: Boolean = False);
  4788. var
  4789.   MemFile: TMemoryStream;
  4790.  
  4791. begin
  4792.  
  4793.   MemFile := TMemoryStream.Create;
  4794.   MemFile.LoadFromFile(FileName);
  4795.  
  4796.   AttachStream(MemFile, FileName, ContentType, EncodingType, IsEmbedded);
  4797.  
  4798.   MemFile.Free;
  4799. end;
  4800.  
  4801. // Create a mailpart and encode the string
  4802.  
  4803. procedure TMailMessage2000.AttachString(const Text, FileName: String; const ContentType: String = ''; const EncodingType: TEncodingType = etBase64; const IsEmbedded: Boolean = False);
  4804. var
  4805.   MemFile: TMemoryStream;
  4806.  
  4807. begin
  4808.  
  4809.   MemFile := TMemoryStream.Create;
  4810.   MemFile.WriteBuffer(Text[1], Length(Text));
  4811.  
  4812.   AttachStream(MemFile, FileName, ContentType, EncodingType, IsEmbedded);
  4813.  
  4814.   MemFile.Free;
  4815. end;
  4816.  
  4817. // Create a mailpart and encode the stream
  4818.  
  4819. procedure TMailMessage2000.AttachStream(const AStream: TStream; const FileName: String; const ContentType: String = ''; const EncodingType: TEncodingType = etBase64; const IsEmbedded: Boolean = False);
  4820. var
  4821.   Part, Father: TMailPart;
  4822.  
  4823. begin
  4824.  
  4825.   if IsEmbedded then
  4826.   begin
  4827.  
  4828.     Normalize(nrAddEmbedded);
  4829.     Father := FRelatedPart;
  4830.   end
  4831.   else
  4832.   begin
  4833.  
  4834.     Normalize(nrAddAttach);
  4835.     Father := FMixedPart;
  4836.   end;
  4837.  
  4838.   if Father <> nil then
  4839.   begin
  4840.  
  4841.     Part := TMailPart.Create(Self);
  4842.     Part.FOwnerMessage := Self;
  4843.     Part.FOwnerPart := Father;
  4844.     Part.FParentBoundary := Father.GetBoundary;
  4845.     Father.FSubPartList.Add(Part);
  4846.   end
  4847.   else
  4848.   begin
  4849.  
  4850.     Part := Self;
  4851.   end;
  4852.  
  4853.   AStream.Position := 0;
  4854.   Part.Decoded.LoadFromStream(AStream);
  4855.   Part.Decoded.Position := 0;
  4856.   Part.Encode(EncodingType);
  4857.  
  4858.   if ContentType = '' then
  4859.     Part.SetLabelValue(_C_T, GetMimeType(ExtractFileName(FileName)))
  4860.   else
  4861.     Part.SetLabelValue(_C_T, ContentType);
  4862.  
  4863.   Part.SetLabelParamValue(_C_T, 'name', '"'+EncodeLine7Bit(ExtractFileName(FileName), FCharSet)+'"');
  4864.   Part.SetLabelParamValue(_C_D, 'filename', '"'+EncodeLine7Bit(ExtractFileName(FileName), FCharSet)+'"');
  4865.   Part.SetLabelValue(_C_L, IntToStr(Part.FBody.Size));
  4866.   Part.FEmbedded := IsEmbedded;
  4867.  
  4868.   if IsEmbedded then
  4869.   begin
  4870.  
  4871.     Part.SetLabelValue(_C_D, _INLN);
  4872.     Part.SetLabelValue(_C_ID, '<'+ExtractFileName(FileName)+'>');
  4873.   end
  4874.   else
  4875.   begin
  4876.  
  4877.     Part.SetLabelValue(_C_D, _ATCH);
  4878.   end;
  4879.  
  4880.   FAttachList.Add(Part);
  4881.  
  4882.   FNeedRebuild := True;
  4883. end;
  4884.  
  4885. // Remove attached file from message
  4886.  
  4887. procedure TMailMessage2000.DetachFile(const FileName: String);
  4888. var
  4889.   nLoop: Integer;
  4890.  
  4891. begin
  4892.  
  4893.   Normalize(nrFirst);
  4894.  
  4895.   for nLoop := 0 to FAttachList.Count-1 do
  4896.   begin
  4897.  
  4898.     if LowerCase(FAttachList[nLoop].FileName) = LowerCase(ExtractFileName(FileName)) then
  4899.     begin
  4900.  
  4901.       if FAttachList[nLoop] <> Self then
  4902.       begin
  4903.  
  4904.         FAttachList[nLoop].Remove;
  4905.         FAttachList[nLoop].Free;
  4906.       end
  4907.       else
  4908.       begin
  4909.  
  4910.         SetLabelValue(_C_T, '');
  4911.         SetLabelValue(_C_TE, '');
  4912.         SetLabelValue(_C_D, '');
  4913.         SetLabelValue(_C_L, '');
  4914.         SetLabelValue(_C_ID, '');
  4915.         FBody.Clear;
  4916.         FDecoded.Clear;
  4917.       end;
  4918.  
  4919.       FAttachList.Delete(nLoop);
  4920.       FNeedRebuild := True;
  4921.       Break;
  4922.     end;
  4923.   end;
  4924.  
  4925.   if not FNeedRebuild then
  4926.     raise Exception.Create(Format('%s: Attachment filename not found %s', [Self.Name, FileName]))
  4927.   else
  4928.     Normalize(nrForce);
  4929. end;
  4930.  
  4931. // Remove attached file from message by AttachList index
  4932.  
  4933. procedure TMailMessage2000.DetachFileIndex(const Index: Integer);
  4934. begin
  4935.  
  4936.   Normalize(nrFirst);
  4937.  
  4938.   if (Index < FAttachList.Count) and (Index >= 0) then
  4939.   begin
  4940.  
  4941.     if FAttachList[Index] <> Self then
  4942.     begin
  4943.  
  4944.       FAttachList[Index].Remove;
  4945.       FAttachList[Index].Free;
  4946.     end
  4947.     else
  4948.     begin
  4949.  
  4950.       SetLabelValue(_C_T, '');
  4951.       SetLabelValue(_C_TE, '');
  4952.       SetLabelValue(_C_D, '');
  4953.       SetLabelValue(_C_L, '');
  4954.       SetLabelValue(_C_ID, '');
  4955.       FBody.Clear;
  4956.       FDecoded.Clear;
  4957.     end;
  4958.  
  4959.     FAttachList.Delete(Index);
  4960.     FNeedRebuild := True;
  4961.     Normalize(nrForce);
  4962.   end
  4963.   else
  4964.     raise Exception.Create(Self.Name+': Attachment index not found');
  4965. end;
  4966.  
  4967. // Find the part containing the specified attachment
  4968.  
  4969. function TMailMessage2000.GetAttach(const FileName: String): TMailPart;
  4970. var
  4971.   nLoop: Integer;
  4972.  
  4973. begin
  4974.  
  4975.   Normalize(nrFirst);
  4976.  
  4977.   Result := nil;
  4978.  
  4979.   for nLoop := 0 to FAttachList.Count-1 do
  4980.   begin
  4981.  
  4982.     if LowerCase(FAttachList[nLoop].FileName) = LowerCase(FileName) then
  4983.     begin
  4984.  
  4985.       Result := FAttachList[nLoop];
  4986.       Break;
  4987.     end;
  4988.   end;
  4989. end;
  4990.  
  4991. // Rebuild body text according to the mailparts
  4992.  
  4993. procedure TMailMessage2000.RebuildBody;
  4994. var
  4995.   sLine: String;
  4996.  
  4997.   procedure RebuildBodyRec(MP: TMailPart);
  4998.   var
  4999.     Loop: Integer;
  5000.     Line: Integer;
  5001.     Data: String;
  5002.     nPos: Integer;
  5003.  
  5004.   begin
  5005.  
  5006.     for Loop := 0 to MP.SubPartList.Count-1 do
  5007.     begin
  5008.  
  5009.       sLine := #13#10;
  5010.       FBody.Write(sLine[1], Length(sLine));
  5011.  
  5012.       sLine :=  '--'+MP.SubPartList[Loop].FParentBoundary+#13#10;
  5013.       FBody.Write(sLine[1], Length(sLine));
  5014.  
  5015.       for Line := 0 to MP.SubPartList[Loop].FHeader.Count-1 do
  5016.       begin
  5017.  
  5018.         if Length(MP.SubPartList[Loop].FHeader[Line]) > 0 then
  5019.         begin
  5020.  
  5021.           sLine := MP.SubPartList[Loop].FHeader[Line]+#13#10;
  5022.           FBody.Write(sLine[1], Length(sLine));
  5023.         end;
  5024.       end;
  5025.  
  5026.       sLine := #13#10;
  5027.       FBody.Write(sLine[1], Length(sLine));
  5028.  
  5029.       if MP.SubPartList[Loop].SubPartList.Count > 0 then
  5030.       begin
  5031.  
  5032.         RebuildBodyRec(MP.SubPartList[Loop]);
  5033.       end
  5034.       else
  5035.       begin
  5036.  
  5037.         SetLength(Data, MP.SubPartList[Loop].FBody.Size);
  5038.  
  5039.         if MP.SubPartList[Loop].FBody.Size > 0 then
  5040.         begin
  5041.  
  5042.           MP.SubPartList[Loop].FBody.Position := 0;
  5043.           MP.SubPartList[Loop].FBody.ReadBuffer(Data[1], MP.SubPartList[Loop].FBody.Size);
  5044.  
  5045.           nPos := 1;
  5046.  
  5047.           while nPos >= 0 do
  5048.           begin
  5049.  
  5050.             DataLine(Data, sLine, nPos);
  5051.  
  5052.             sLine := sLine;
  5053.             FBody.Write(sLine[1], Length(sLine));
  5054.           end;
  5055.         end;
  5056.       end;
  5057.     end;
  5058.  
  5059.     if MP.SubPartList.Count > 0 then
  5060.     begin
  5061.  
  5062.       sLine := #13#10;
  5063.       FBody.Write(sLine[1], Length(sLine));
  5064.  
  5065.       sLine := '--'+MP.SubPartList[0].FParentBoundary+'--'#13#10;
  5066.       FBody.Write(sLine[1], Length(sLine));
  5067.     end;
  5068.   end;
  5069.  
  5070. begin
  5071.  
  5072.   if not FNeedRebuild then
  5073.     Exit;
  5074.  
  5075.   if SubPartList.Count > 0 then
  5076.   begin
  5077.  
  5078.     FBody.Clear;
  5079.  
  5080.     sLine := _MIME_Msg;
  5081.     FBody.Write(sLine[1], Length(sLine));
  5082.  
  5083.     RebuildBodyRec(Self);
  5084.   end;
  5085.  
  5086.   SetLabelValue(_C_L, IntToStr(FBody.Size));
  5087.  
  5088.   FNeedRebuild := False;
  5089. end;
  5090.  
  5091. // Empty data stored in the object
  5092.  
  5093. procedure TMailMessage2000.Reset;
  5094. var
  5095.   Loop: Integer;
  5096.  
  5097. begin
  5098.  
  5099.   for Loop := 0 to FSubPartList.Count-1 do
  5100.     FSubPartList.Items[Loop].Destroy;
  5101.  
  5102.   FHeader.Clear;
  5103.   FBody.Clear;
  5104.   FDecoded.Clear;
  5105.   FSubPartList.Clear;
  5106.  
  5107.   FAttachList.Clear;
  5108.   FTextPlain.Clear;
  5109.   FTextHTML.Clear;
  5110.   FTextPlainPart := nil;
  5111.   FTextHTMLPart := nil;
  5112.   FMixedPart := nil;
  5113.   FRelatedPart := nil;
  5114.   FAlternativePart := nil;
  5115.   FNeedRebuild := False;
  5116.   FNeedNormalize := False;
  5117.   FNeedFindParts := False;
  5118.   FNameCount := 0;
  5119. end;
  5120.  
  5121. { TSocketTalk =================================================================== }
  5122.  
  5123. // Initialize TSocketTalk
  5124.  
  5125. constructor TSocketTalk.Create(AOwner: TComponent);
  5126. begin
  5127.  
  5128.   inherited Create(AOwner);
  5129.  
  5130.   FClientSocket := TClientSocket.Create(Self);
  5131.   FClientSocket.ClientType := ctNonBlocking;
  5132.   FClientSocket.OnRead := SocketRead;
  5133.   FClientSocket.OnDisconnect := SocketDisconnect;
  5134.   FClientSocket.Socket.OnErrorEvent := SocketError;
  5135.  
  5136.   FTimer := TTimer.Create(Self);
  5137.   FTimer.Enabled := False;
  5138.   FTimer.OnTimer := Timer;
  5139.  
  5140.   FTimeOut := 60;
  5141.   FLastResponse := '';
  5142.   FExpectedEnd := '';
  5143.   FDataSize := 0;
  5144.   FPacketSize := 0;
  5145.   FTalkError := teNoError;
  5146. end;
  5147.  
  5148. // Finalize TSocketTalk
  5149.  
  5150. destructor TSocketTalk.Destroy;
  5151. begin
  5152.  
  5153.   FClientSocket.Free;
  5154.   FTimer.Free;
  5155.  
  5156.   inherited Destroy;
  5157. end;
  5158.  
  5159. // Occurs when data is comming from the socket
  5160.  
  5161. procedure TSocketTalk.SocketRead(Sender: TObject; Socket: TCustomWinSocket);
  5162. var
  5163.   Buffer: String;
  5164.   BufLen: Integer;
  5165.  
  5166. begin
  5167.  
  5168.   SetLength(Buffer, Socket.ReceiveLength);
  5169.   BufLen := Socket.ReceiveBuf(Buffer[1], Length(Buffer));
  5170.   FLastResponse := FLastResponse + Copy(Buffer, 1, BufLen);
  5171.   FTalkError := teNoError;
  5172.   FTimer.Enabled := False;
  5173.  
  5174.   if Assigned(FOnReceiveData) then
  5175.   begin
  5176.  
  5177.     FOnReceiveData(Self, FSessionState, Buffer, FServerResult);
  5178.   end;
  5179.  
  5180.   if (FDataSize > 0) and Assigned(FOnProgress) then
  5181.   begin
  5182.  
  5183.     FOnProgress(Self.Owner, FDataSize, Length(FLastResponse));
  5184.   end;
  5185.  
  5186.   if (FExpectedEnd = '') or (Copy(FLastResponse, Length(FLastResponse)-Length(FExpectedEnd)+1, Length(FExpectedEnd)) = FExpectedEnd) then
  5187.   begin
  5188.  
  5189.     FTalkError := teNoError;
  5190.     FDataSize := 0;
  5191.     FExpectedEnd := '';
  5192.     FWaitingServer := False;
  5193.  
  5194.     if Assigned(FOnEndOfData) then
  5195.     begin
  5196.  
  5197.       FOnEndOfData(Self, FSessionState, FLastResponse, FServerResult);
  5198.     end;
  5199.  
  5200.     FSessionState := stNone;
  5201.   end
  5202.   else
  5203.   begin
  5204.  
  5205.     FTimer.Enabled := True;
  5206.   end;
  5207. end;
  5208.  
  5209. // Occurs when socket is disconnected
  5210.  
  5211. procedure TSocketTalk.SocketDisconnect(Sender: TObject; Socket: TCustomWinSocket);
  5212. begin
  5213.  
  5214.   if Assigned(FOnDisconnect) then
  5215.     FOnDisconnect(Self);
  5216.  
  5217.   FTimer.Enabled := False;
  5218.   FWaitingServer := False;
  5219.   FSessionState := stNone;
  5220.   FExpectedEnd := '';
  5221.   FDataSize := 0;
  5222.   FPacketSize := 0;
  5223. end;
  5224.  
  5225. // Occurs on socket error
  5226.  
  5227. procedure TSocketTalk.SocketError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
  5228. begin
  5229.  
  5230.   FTimer.Enabled := False;
  5231.   FTalkError := TTalkError(Ord(ErrorEvent));
  5232.   FDataSize := 0;
  5233.   FExpectedEnd := '';
  5234.   FWaitingServer := False;
  5235.   FServerResult := False;
  5236.  
  5237.   if Assigned(FOnSocketTalkError) then
  5238.   begin
  5239.  
  5240.     FOnSocketTalkError(Self, FSessionState, FTalkError);
  5241.   end;
  5242.  
  5243.   FSessionState := stNone;
  5244.   ErrorCode := 0;
  5245. end;
  5246.  
  5247. // Occurs on timeout
  5248.  
  5249. procedure TSocketTalk.Timer(Sender: TObject);
  5250. begin
  5251.  
  5252.   FTimer.Enabled := False;
  5253.   FTalkError := teTimeout;
  5254.   FDataSize := 0;
  5255.   FExpectedEnd := '';
  5256.   FWaitingServer := False;
  5257.   FServerResult := False;
  5258.  
  5259.   if Assigned(FOnSocketTalkError) then
  5260.   begin
  5261.  
  5262.     FOnSocketTalkError(Self, FSessionState, FTalkError);
  5263.   end;
  5264.  
  5265.   FSessionState := stNone;
  5266. end;
  5267.  
  5268. // Cancel the waiting for server response
  5269.  
  5270. procedure TSocketTalk.Cancel;
  5271. begin
  5272.  
  5273.   FTimer.Enabled := False;
  5274.   FTalkError := teNoError;
  5275.   FSessionState := stNone;
  5276.   FExpectedEnd := '';
  5277.   FDataSize := 0;
  5278.   FWaitingServer := False;
  5279.   FServerResult := False;
  5280. end;
  5281.  
  5282. // Inform that the data comming belongs
  5283.  
  5284. procedure TSocketTalk.ForceState(SessionState: TSessionState);
  5285. begin
  5286.  
  5287.   FExpectedEnd := '';
  5288.   FLastResponse := '';
  5289.   FTimer.Interval := FTimeOut * 1000;
  5290.   FTimer.Enabled := True;
  5291.   FDataSize := 0;
  5292.   FTalkError := teNoError;
  5293.   FSessionState := SessionState;
  5294.   FWaitingServer := True;
  5295.   FServerResult := False;
  5296. end;
  5297.  
  5298. // Send a command to server
  5299.  
  5300. procedure TSocketTalk.Talk(Buffer, EndStr: String; SessionState: TSessionState);
  5301. var
  5302.   nPos: Integer;
  5303.   nLen: Integer;
  5304.  
  5305. begin
  5306.  
  5307.   FExpectedEnd := EndStr;
  5308.   FSessionState := SessionState;
  5309.   FLastResponse := '';
  5310.   FTimer.Interval := FTimeOut * 1000;
  5311.   FTalkError := teNoError;
  5312.   FWaitingServer := True;
  5313.   FServerResult := False;
  5314.   nPos := 1;
  5315.  
  5316.   if (FPacketSize > 0) and (Length(Buffer) > FPacketSize) then
  5317.   begin
  5318.  
  5319.     if Assigned(OnProgress) then
  5320.       OnProgress(Self.Owner, Length(Buffer), 0);
  5321.  
  5322.     while nPos <= Length(Buffer) do
  5323.     begin
  5324.  
  5325.       Application.ProcessMessages;
  5326.  
  5327.       if (nPos+FPacketSize-1) > Length(Buffer) then
  5328.         nLen := Length(Buffer)-nPos+1
  5329.       else
  5330.         nLen := FPacketSize;
  5331.  
  5332.       FTimer.Enabled := True;
  5333.  
  5334.       while (FClientSocket.Socket.SendBuf(Buffer[nPos], nLen) = -1) do
  5335.         Sleep(10);
  5336.  
  5337.       FTimer.Enabled := False;
  5338.       nPos := nPos + nLen;
  5339.  
  5340.       if Assigned(OnProgress) then
  5341.         OnProgress(Self.Owner, Length(Buffer), nPos-1);
  5342.     end;
  5343.  
  5344.     if Assigned(OnProgress) then
  5345.       OnProgress(Self.Owner, Length(Buffer), Length(Buffer));
  5346.   end
  5347.   else
  5348.   begin
  5349.  
  5350.     while (FClientSocket.Socket.SendBuf(Buffer[1], Length(Buffer)) = -1 )
  5351.        do Sleep (10);
  5352.   end;
  5353.  
  5354.   FPacketSize := 0;
  5355. end;
  5356.  
  5357. // Wait for server response
  5358. // by Rene de Jong (rmdejong@ism.nl)
  5359.  
  5360. procedure TSocketTalk.WaitServer;
  5361. begin
  5362.  
  5363.   FTimer.Interval := FTimeOut * 1000;
  5364.  
  5365.   while FWaitingServer and (not FServerResult) do
  5366.   begin
  5367.  
  5368.     FTimer.Enabled := True;
  5369.     Application.ProcessMessages;
  5370.   end;
  5371.  
  5372.   FTimer.Enabled:= False;
  5373. end;
  5374.  
  5375. { TPOP2000 ====================================================================== }
  5376.  
  5377. // Initialize TPOP2000
  5378.  
  5379. constructor TPOP2000.Create;
  5380. begin
  5381.  
  5382.   FSocketTalk := TSocketTalk.Create(Self);
  5383.   FSocketTalk.OnEndOfData := EndOfData;
  5384.   FSocketTalk.OnSocketTalkError := SocketTalkError;
  5385.   FSocketTalk.OnReceiveData := ReceiveData;
  5386.   FSocketTalk.OnDisconnect := SocketDisconnect;
  5387.  
  5388.   FHost := '';
  5389.   FPort := 110;
  5390.   FUserName := '';
  5391.   FPassword := '';
  5392.   FSessionMessageCount := -1;
  5393.   FSessionConnected := False;
  5394.   FSessionLogged := False;
  5395.   FMailMessage := nil;
  5396.   FDeleteOnRetrieve := False;
  5397.  
  5398.   SetLength(FSessionMessageSize, 0);
  5399.  
  5400.   inherited Create(AOwner);
  5401. end;
  5402.  
  5403. // Finalize TPOP2000
  5404.  
  5405. destructor TPOP2000.Destroy;
  5406. begin
  5407.  
  5408.   FSocketTalk.Free;
  5409.  
  5410.   SetLength(FSessionMessageSize, 0);
  5411.  
  5412.   inherited Destroy;
  5413. end;
  5414.  
  5415. // Set timeout
  5416.  
  5417. procedure TPOP2000.SetTimeOut(Value: Integer);
  5418. begin
  5419.  
  5420.   FSocketTalk.TimeOut := Value;
  5421. end;
  5422.  
  5423. // Get timeout
  5424.  
  5425. function TPOP2000.GetTimeOut: Integer;
  5426. begin
  5427.  
  5428.   Result := FSocketTalk.TimeOut;
  5429. end;
  5430.  
  5431. // Set OnProgress event
  5432.  
  5433. procedure TPOP2000.SetProgress(Value: TProgressEvent);
  5434. begin
  5435.  
  5436.   FSocketTalk.OnProgress := Value;
  5437. end;
  5438.  
  5439. // Get OnProgress event
  5440.  
  5441. function TPOP2000.GetProgress: TProgressEvent;
  5442. begin
  5443.  
  5444.   Result := FSocketTalk.OnProgress;
  5445. end;
  5446.  
  5447. // Get LastResponse
  5448.  
  5449. function TPOP2000.GetLastResponse: String;
  5450. begin
  5451.  
  5452.   Result := FSocketTalk.LastResponse;
  5453. end;
  5454.  
  5455. // When data from server ends
  5456.  
  5457. procedure TPOP2000.EndOfData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
  5458. begin
  5459.  
  5460.   case SessionState of
  5461.  
  5462.     stConnect, stUser, stPass, stStat, stList, stRetr, stQuit, stDele, stUIDL:
  5463.     if Copy(Data, 1, 3) = '+OK' then
  5464.       ServerResult := True;
  5465.   end;
  5466. end;
  5467.  
  5468. // On socket error
  5469.  
  5470. procedure TPOP2000.SocketTalkError(Sender: TObject; SessionState: TSessionState; TalkError: TTalkError);
  5471. begin
  5472.  
  5473.   FSocketTalk.Cancel;
  5474. end;
  5475.  
  5476. // On data received
  5477.  
  5478. procedure TPOP2000.ReceiveData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
  5479. begin
  5480.  
  5481.   if (Copy(Data, 1, 4) = '-ERR') and (Copy(Data, Length(Data)-1, 2) = #13#10) then
  5482.   begin
  5483.  
  5484.     ServerResult := False;
  5485.     FSocketTalk.Cancel;
  5486.   end;
  5487. end;
  5488.  
  5489. // On socket disconnected
  5490.  
  5491. procedure TPOP2000.SocketDisconnect(Sender: TObject);
  5492. begin
  5493.  
  5494.   FSessionMessageCount := -1;
  5495.   FSessionConnected := False;
  5496.   FSessionLogged := False;
  5497.  
  5498.   SetLength(FSessionMessageSize, 0);
  5499. end;
  5500.  
  5501. // Connect socket
  5502.  
  5503. function TPOP2000.Connect: Boolean;
  5504. begin
  5505.  
  5506.   if FSessionConnected or FSocketTalk.ClientSocket.Active then
  5507.   begin
  5508.  
  5509.     Result := False;
  5510.     Exit;
  5511.   end;
  5512.  
  5513.   if Length(FHost) = 0 then
  5514.   begin
  5515.  
  5516.     Result := False;
  5517.     Exit;
  5518.   end;
  5519.  
  5520.   if not IsIPAddress(FHost) then
  5521.   begin
  5522.  
  5523.     FSocketTalk.ClientSocket.Host := FHost;
  5524.     FSocketTalk.ClientSocket.Address := '';
  5525.   end
  5526.   else
  5527.   begin
  5528.  
  5529.     FSocketTalk.ClientSocket.Host := '';
  5530.     FSocketTalk.ClientSocket.Address := FHost;
  5531.   end;
  5532.  
  5533.   FSocketTalk.ClientSocket.Port := FPort;
  5534.   FSocketTalk.ForceState(stConnect);
  5535.   FSocketTalk.ClientSocket.Open;
  5536.  
  5537.   FSocketTalk.WaitServer;
  5538.  
  5539.   FSessionConnected := FSocketTalk.ServerResult;
  5540.   Result := FSocketTalk.ServerResult;
  5541. end;
  5542.  
  5543. // POP3 Logon
  5544.  
  5545. function TPOP2000.Login: Boolean;
  5546. var
  5547.   MsgList: TStringList;
  5548.   Loop: Integer;
  5549.   cStat: String;
  5550.  
  5551. begin
  5552.  
  5553.   Result := False;
  5554.  
  5555.   if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
  5556.   begin
  5557.  
  5558.     Exit;
  5559.   end;
  5560.  
  5561.   FSocketTalk.Talk('USER'#32+FUserName+#13#10, #13#10, stUser);
  5562.   FSocketTalk.WaitServer;
  5563.  
  5564.   if FSocketTalk.ServerResult then
  5565.   begin
  5566.  
  5567.     FSocketTalk.Talk('PASS'#32+FPassword+#13#10, #13#10, stPass);
  5568.     FSocketTalk.WaitServer;
  5569.  
  5570.     if FSocketTalk.ServerResult then
  5571.     begin
  5572.  
  5573.       FSessionLogged := True;
  5574.  
  5575.       FSocketTalk.Talk('LIST'#13#10, _DATAEND1, stList);
  5576.       FSocketTalk.WaitServer;
  5577.  
  5578.       if FSocketTalk.ServerResult then
  5579.       begin
  5580.  
  5581.         MsgList := TStringList.Create;
  5582.         MsgList.Text := FSocketTalk.LastResponse;
  5583.  
  5584.         if MsgList.Count > 2 then
  5585.         begin
  5586.  
  5587.           cStat := TrimSpace(MsgList[MsgList.Count-2]);
  5588.  
  5589.           FSessionMessageCount := StrToIntDef(Copy(cStat, 1, Pos(#32, cStat)-1), -1);
  5590.  
  5591.           if FSessionMessageCount > 0 then
  5592.           begin
  5593.  
  5594.             for Loop := 1 to MsgList.Count-2 do
  5595.             begin
  5596.  
  5597.               cStat := TrimSpace(MsgList[Loop]);
  5598.               cStat := Copy(cStat, 1, Pos(#32, cStat)-1);
  5599.  
  5600.               SetLength(FSessionMessageSize, StrToInt(cStat)+1);
  5601.  
  5602.               if StrToIntDef(cStat, 0) > 0 then
  5603.                 FSessionMessageSize[StrToInt(cStat)] := StrToIntDef(Copy(MsgList[Loop], Pos(#32, MsgList[Loop])+1, 99), 0);
  5604.             end;
  5605.  
  5606.             FSessionMessageSize[0] := 0;
  5607.           end;
  5608.         end
  5609.         else
  5610.         begin
  5611.  
  5612.           FSessionMessageCount := 0;
  5613.           SetLength(FSessionMessageSize, 0);
  5614.         end;
  5615.  
  5616.         MsgList.Free;
  5617.       end;
  5618.     end;
  5619.   end;
  5620.  
  5621.   Result := FSessionLogged;
  5622. end;
  5623.  
  5624. // POP3 Quit
  5625.  
  5626. function TPOP2000.Quit: Boolean;
  5627. begin
  5628.  
  5629.   Result := False;
  5630.  
  5631.   if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
  5632.   begin
  5633.  
  5634.     Exit;
  5635.   end;
  5636.  
  5637.   FSocketTalk.Talk('QUIT'#13#10, #13#10, stQuit);
  5638.   FSocketTalk.WaitServer;
  5639.  
  5640.   if FSocketTalk.ServerResult then
  5641.   begin
  5642.  
  5643.     FSocketTalk.ClientSocket.Close;
  5644.     FSessionConnected := False;
  5645.     FSessionLogged := False;
  5646.     FSessionMessageCount := -1;
  5647.     Result := True;
  5648.   end;
  5649. end;
  5650.  
  5651. // Force disconnection
  5652.  
  5653. procedure TPOP2000.Abort;
  5654. begin
  5655.  
  5656.   FSocketTalk.ClientSocket.Close;
  5657.   FSessionConnected := False;
  5658.   FSessionLogged := False;
  5659.   FSessionMessageCount := -1;
  5660. end;
  5661.  
  5662. // Retrieve message#
  5663.  
  5664. function TPOP2000.RetrieveMessage(Number: Integer): Boolean;
  5665. var
  5666.   MailTxt: TStringList;
  5667.  
  5668. begin
  5669.  
  5670.   Result := False;
  5671.   FLastMessage := '';
  5672.  
  5673.   if (not FSessionConnected) or (not FSessionLogged) or (not FSocketTalk.ClientSocket.Active) then
  5674.   begin
  5675.  
  5676.     Exit;
  5677.   end;
  5678.  
  5679.   FSocketTalk.DataSize := FSessionMessageSize[Number-1];
  5680.   FSocketTalk.Talk('RETR'#32+IntToStr(Number)+#13#10, _DATAEND1, stRetr);
  5681.   FSocketTalk.WaitServer;
  5682.  
  5683.   if FSocketTalk.ServerResult then
  5684.   begin
  5685.  
  5686.     MailTxt := TStringList.Create;
  5687.     MailTxt.Text := FSocketTalk.LastResponse;
  5688.     MailTxt.Delete(MailTxt.Count-1);
  5689.     MailTxt.Delete(0);
  5690.     FLastMessage := MailTxt.Text;
  5691.     MailTxt.Free;
  5692.  
  5693.     if Assigned(FMailMessage) then
  5694.     begin
  5695.  
  5696.       FMailMessage.Reset;
  5697.       FMailMessage.Fill(PChar(FLastMessage), True);
  5698.     end;
  5699.  
  5700.     Result := True;
  5701.  
  5702.     if FDeleteOnRetrieve then
  5703.       DeleteMessage(Number);
  5704.   end;
  5705. end;
  5706.  
  5707. // Retrieve message# (only header)
  5708.  
  5709. function TPOP2000.RetrieveHeader(Number: Integer; Lines: Integer = 0): Boolean;
  5710. var
  5711.   MailTxt: TStringList;
  5712.  
  5713. begin
  5714.  
  5715.   Result := False;
  5716.   FLastMessage := '';
  5717.  
  5718.   if (not FSessionConnected) or (not FSessionLogged) or (not FSocketTalk.ClientSocket.Active) then
  5719.   begin
  5720.  
  5721.     Exit;
  5722.   end;
  5723.  
  5724.   FSocketTalk.DataSize := FSessionMessageSize[Number-1];
  5725.   FSocketTalk.Talk('TOP'#32+IntToStr(Number)+#32+IntToStr(Lines)+#13#10, _DATAEND1, stRetr);
  5726.   FSocketTalk.WaitServer;
  5727.  
  5728.   if FSocketTalk.ServerResult then
  5729.   begin
  5730.  
  5731.     MailTxt := TStringList.Create;
  5732.     MailTxt.Text := FSocketTalk.LastResponse;
  5733.     MailTxt.Delete(MailTxt.Count-1);
  5734.     MailTxt.Delete(0);
  5735.     FLastMessage := MailTxt.Text;
  5736.  
  5737.     if Assigned(FMailMessage) then
  5738.     begin
  5739.  
  5740.       FMailMessage.Reset;
  5741.       FMailMessage.FHeader.Text := PChar(FLastMessage);
  5742.     end;
  5743.  
  5744.     Result := True;
  5745.   end;
  5746. end;
  5747.  
  5748. // Delete message#
  5749.  
  5750. function TPOP2000.DeleteMessage(Number: Integer): Boolean;
  5751. begin
  5752.  
  5753.   Result := False;
  5754.  
  5755.   if (not FSessionConnected) or (not FSessionLogged) or (not FSocketTalk.ClientSocket.Active) then
  5756.   begin
  5757.  
  5758.     Exit;
  5759.   end;
  5760.  
  5761.   FSocketTalk.Talk('DELE'#32+IntToStr(Number)+#13#10, #13#10, stDele);
  5762.   FSocketTalk.WaitServer;
  5763.  
  5764.   if FSocketTalk.ServerResult then
  5765.   begin
  5766.  
  5767.     Result := True;
  5768.   end;
  5769. end;
  5770.  
  5771. // Get UIDL from message#
  5772.  
  5773. function TPOP2000.GetUIDL(Number: Integer): String;
  5774. var
  5775.   MsgNum: String;
  5776.  
  5777. begin
  5778.  
  5779.   Result := '';
  5780.   MsgNum := IntToStr(Number);
  5781.  
  5782.   if (not FSessionConnected) or (not FSessionLogged) or (not FSocketTalk.ClientSocket.Active) then
  5783.   begin
  5784.  
  5785.     Exit;
  5786.   end;
  5787.  
  5788.   FSocketTalk.Talk('UIDL'#32+MsgNum+#13#10, #13#10, stUIDL);
  5789.   FSocketTalk.WaitServer;
  5790.  
  5791.   if FSocketTalk.ServerResult then
  5792.   begin
  5793.  
  5794.     Result := FSocketTalk.LastResponse;
  5795.     Result := Trim(Copy(Result, Pos(MsgNum+#32, Result)+Length(MsgNum)+1, Length(Result)));
  5796.   end;
  5797. end;
  5798.  
  5799. { TSMTP2000 ====================================================================== }
  5800.  
  5801. // Initialize TSMTP2000
  5802.  
  5803. constructor TSMTP2000.Create;
  5804. begin
  5805.  
  5806.   FSocketTalk := TSocketTalk.Create(Self);
  5807.   FSocketTalk.OnEndOfData := EndOfData;
  5808.   FSocketTalk.OnSocketTalkError := SocketTalkError;
  5809.   FSocketTalk.OnReceiveData := ReceiveData;
  5810.   FSocketTalk.OnDisconnect := SocketDisconnect;
  5811.  
  5812.   FHost := '';
  5813.   FPort := 25;
  5814.   FSessionConnected := False;
  5815.   FPacketSize := 102400;
  5816.  
  5817.   inherited Create(AOwner);
  5818. end;
  5819.  
  5820. // Finalize TSMTP2000
  5821.  
  5822. destructor TSMTP2000.Destroy;
  5823. begin
  5824.  
  5825.   FSocketTalk.Free;
  5826.  
  5827.   inherited Destroy;
  5828. end;
  5829.  
  5830. // Set timeout
  5831.  
  5832. procedure TSMTP2000.SetTimeOut(Value: Integer);
  5833. begin
  5834.  
  5835.   FSocketTalk.TimeOut := Value;
  5836. end;
  5837.  
  5838. // Get timeout
  5839.  
  5840. function TSMTP2000.GetTimeOut: Integer;
  5841. begin
  5842.  
  5843.   Result := FSocketTalk.TimeOut;
  5844. end;
  5845.  
  5846. // Set OnProgress event
  5847.  
  5848. procedure TSMTP2000.SetProgress(Value: TProgressEvent);
  5849. begin
  5850.  
  5851.   FSocketTalk.OnProgress := Value;
  5852. end;
  5853.  
  5854. // Get OnProgress event
  5855.  
  5856. function TSMTP2000.GetProgress: TProgressEvent;
  5857. begin
  5858.  
  5859.   Result := FSocketTalk.OnProgress;
  5860. end;
  5861.  
  5862. // Get LastResponse
  5863.  
  5864. function TSMTP2000.GetLastResponse: String;
  5865. begin
  5866.  
  5867.   Result := FSocketTalk.LastResponse;
  5868. end;
  5869.  
  5870. // When data from server ends
  5871.  
  5872. procedure TSMTP2000.EndOfData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
  5873. begin
  5874.  
  5875.   case SessionState of
  5876.  
  5877.     stConnect:
  5878.     if Copy(Data, 1, 3) = '220' then
  5879.       ServerResult := True;
  5880.  
  5881.     stHelo, stMail, stRcpt, stSendData:
  5882.     if Copy(Data, 1, 3) = '250' then
  5883.       ServerResult := True;
  5884.  
  5885.     stData:
  5886.     if Copy(Data, 1, 3) = '354' then
  5887.       ServerResult := True;
  5888.  
  5889.     stQuit:
  5890.     if Copy(Data, 1, 3) = '221' then
  5891.       ServerResult := True;
  5892.   end;
  5893. end;
  5894.  
  5895. // On socket error
  5896.  
  5897. procedure TSMTP2000.SocketTalkError(Sender: TObject; SessionState: TSessionState; TalkError: TTalkError);
  5898. begin
  5899.  
  5900.   FSocketTalk.Cancel;
  5901. end;
  5902.  
  5903. // On data received
  5904.  
  5905. procedure TSMTP2000.ReceiveData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
  5906. begin
  5907.  
  5908.   if (StrToIntDef(Copy(Data, 1, 3), 0) >= 500) and (Copy(Data, Length(Data)-1, 2) = #13#10) then
  5909.   begin
  5910.  
  5911.     ServerResult := False;
  5912.     FSocketTalk.Cancel;
  5913.   end;
  5914. end;
  5915.  
  5916. // On socket disconnected
  5917.  
  5918. procedure TSMTP2000.SocketDisconnect(Sender: TObject);
  5919. begin
  5920.  
  5921.   FSessionConnected := False;
  5922. end;
  5923.  
  5924. // Connect socket
  5925.  
  5926. function TSMTP2000.Connect: Boolean;
  5927. begin
  5928.  
  5929.   Result := False;
  5930.  
  5931.   if FSessionConnected or FSocketTalk.ClientSocket.Active then
  5932.   begin
  5933.  
  5934.     Exit;
  5935.   end;
  5936.  
  5937.   if Length(FHost) = 0 then
  5938.   begin
  5939.  
  5940.     Exit;
  5941.   end;
  5942.  
  5943.   if not IsIPAddress(FHost) then
  5944.   begin
  5945.  
  5946.     FSocketTalk.ClientSocket.Host := FHost;
  5947.     FSocketTalk.ClientSocket.Address := '';
  5948.   end
  5949.   else
  5950.   begin
  5951.  
  5952.     FSocketTalk.ClientSocket.Host := '';
  5953.     FSocketTalk.ClientSocket.Address := FHost;
  5954.   end;
  5955.  
  5956.   FSocketTalk.ClientSocket.Port := FPort;
  5957.   FSocketTalk.ForceState(stConnect);
  5958.   FSocketTalk.ClientSocket.Open;
  5959.  
  5960.   FSocketTalk.WaitServer;
  5961.  
  5962.   if FSocketTalk.ServerResult then
  5963.   begin
  5964.  
  5965.     FSocketTalk.Talk('HELO'#32+FSocketTalk.FClientSocket.Socket.LocalHost+#13#10, #13#10, stHelo);
  5966.     FSocketTalk.WaitServer;
  5967.   end;
  5968.  
  5969.   FSessionConnected := FSocketTalk.ServerResult;
  5970.   Result := FSocketTalk.ServerResult;
  5971. end;
  5972.  
  5973. // SMTP Quit
  5974.  
  5975. function TSMTP2000.Quit: Boolean;
  5976. begin
  5977.  
  5978.   Result := False;
  5979.  
  5980.   if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
  5981.   begin
  5982.  
  5983.     Exit;
  5984.   end;
  5985.  
  5986.   FSocketTalk.Talk('QUIT'#13#10, #13#10, stQuit);
  5987.   FSocketTalk.WaitServer;
  5988.  
  5989.   if FSocketTalk.ServerResult then
  5990.   begin
  5991.  
  5992.     FSocketTalk.ClientSocket.Close;
  5993.     FSessionConnected := False;
  5994.     Result := True;
  5995.   end;
  5996. end;
  5997.  
  5998. // Force disconnection
  5999.  
  6000. procedure TSMTP2000.Abort;
  6001. begin
  6002.  
  6003.   FSocketTalk.ClientSocket.Close;
  6004.   FSessionConnected := False;
  6005. end;
  6006.  
  6007. // Send message
  6008.  
  6009. function TSMTP2000.SendMessage: Boolean;
  6010. var
  6011.   sDests: String;
  6012.  
  6013. begin
  6014.  
  6015.   if not Assigned(FMailMessage) then
  6016.   begin
  6017.  
  6018.     Exception.Create(Self.Name+': MailMessage unassigned');
  6019.     Result := False;
  6020.     Exit;
  6021.   end;
  6022.  
  6023.   if FMailMessage.ToList.Count > 0 then
  6024.     sDests := FMailMessage.ToList.AllAddresses;
  6025.  
  6026.   if FMailMessage.CcList.Count > 0 then
  6027.   begin
  6028.  
  6029.     if sDests <> '' then sDests := sDests + ',';
  6030.     sDests := sDests + FMailMessage.CcList.AllAddresses;
  6031.   end;
  6032.  
  6033.   if FMailMessage.BccList.Count > 0 then
  6034.   begin
  6035.  
  6036.     if sDests <> '' then sDests := sDests + ',';
  6037.     sDests := sDests + FMailMessage.BccList.AllAddresses;
  6038.   end;
  6039.  
  6040.   Result := SendMessageTo(FMailMessage.FromAddress, sDests);
  6041. end;
  6042.  
  6043. // Send message to specified recipients
  6044.  
  6045. function TSMTP2000.SendMessageTo(const From, Dests: String): Boolean;
  6046. var
  6047.   Loop: Integer;
  6048.   AllOk: Boolean;
  6049.   sDests: TStringList;
  6050.   sHeader: String;
  6051.  
  6052. begin
  6053.  
  6054.   Result := False;
  6055.  
  6056.   if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
  6057.   begin
  6058.  
  6059.     Exit;
  6060.   end;
  6061.  
  6062.   if not Assigned(FMailMessage) then
  6063.   begin
  6064.  
  6065.     Exception.Create(Self.Name+': MailMessage unassigned');
  6066.     Exit;
  6067.   end;
  6068.  
  6069.   if FMailMessage.FNeedRebuild then
  6070.   begin
  6071.  
  6072.     Exception.Create(Self.Name+': MailMessage need rebuild');
  6073.     Exit;
  6074.   end;
  6075.  
  6076.   sDests := TStringList.Create;
  6077.   sDests.Sorted := True;
  6078.   sDests.Duplicates := dupIgnore;
  6079.   sDests.CommaText := Dests;
  6080.  
  6081.   if sDests.Count = 0 then
  6082.   begin
  6083.  
  6084.     Exception.Create(Self.Name+': No recipients to send message');
  6085.     Exit;
  6086.   end;
  6087.  
  6088.   FSocketTalk.Talk('MAIL FROM: <'+From+'>'#13#10, #13#10, stMail);
  6089.   FSocketTalk.WaitServer;
  6090.  
  6091.   if FSocketTalk.ServerResult then
  6092.   begin
  6093.  
  6094.     AllOk := True;
  6095.  
  6096.     for Loop := 0 to sDests.Count-1 do
  6097.     begin
  6098.  
  6099.       FSocketTalk.Talk('RCPT TO: <'+sDests[Loop]+'>'#13#10, #13#10, stRcpt);
  6100.       FSocketTalk.WaitServer;
  6101.  
  6102.       if not FSocketTalk.ServerResult then
  6103.       begin
  6104.  
  6105.         AllOk := False;
  6106.         Break;
  6107.       end;
  6108.     end;
  6109.  
  6110.     if AllOk then
  6111.     begin
  6112.  
  6113.       FMailMessage.SetMessageId(FSocketTalk.ClientSocket.Socket.LocalAddress);
  6114.       sHeader := FMailMessage.FHeader.Text;
  6115.       FMailMessage.SetLabelValue('Bcc', '');
  6116.  
  6117.       FSocketTalk.Talk('DATA'#13#10, #13#10, stData);
  6118.       FSocketTalk.WaitServer;
  6119.  
  6120.       if FSocketTalk.ServerResult then
  6121.       begin
  6122.  
  6123.         FSocketTalk.PacketSize := FPacketSize;
  6124.         FSocketTalk.Talk(StringReplace(FMailMessage.MessageSource, _DATAEND1, _DATAEND2, [rfReplaceAll])+_DATAEND1, #13#10, stSendData);
  6125.         FSocketTalk.WaitServer;
  6126.  
  6127.         if FSocketTalk.ServerResult then
  6128.         begin
  6129.  
  6130.           Result := True;
  6131.         end;
  6132.       end;
  6133.  
  6134.       FMailMessage.FHeader.Text := sHeader;
  6135.     end;
  6136.   end;
  6137.  
  6138.   sDests.Free;
  6139. end;
  6140.  
  6141. // Send string to specified recipients
  6142.  
  6143. function TSMTP2000.SendStringTo(const Msg, From, Dests: String): Boolean;
  6144. var
  6145.   Loop: Integer;
  6146.   AllOk: Boolean;
  6147.   sDests: TStringList;
  6148.  
  6149. begin
  6150.  
  6151.   Result := False;
  6152.  
  6153.   if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
  6154.   begin
  6155.  
  6156.     Exit;
  6157.   end;
  6158.  
  6159.   sDests := TStringList.Create;
  6160.   sDests.Sorted := True;
  6161.   sDests.Duplicates := dupIgnore;
  6162.   sDests.CommaText := Dests;
  6163.  
  6164.   if sDests.Count = 0 then
  6165.   begin
  6166.  
  6167.     Exception.Create(Self.Name+': No recipients to send message');
  6168.     Exit;
  6169.   end;
  6170.  
  6171.   FSocketTalk.Talk('MAIL FROM: <'+From+'>'#13#10, #13#10, stMail);
  6172.   FSocketTalk.WaitServer;
  6173.  
  6174.   if FSocketTalk.ServerResult then
  6175.   begin
  6176.  
  6177.     AllOk := True;
  6178.  
  6179.     for Loop := 0 to sDests.Count-1 do
  6180.     begin
  6181.  
  6182.       FSocketTalk.Talk('RCPT TO: <'+sDests[Loop]+'>'#13#10, #13#10, stRcpt);
  6183.       FSocketTalk.WaitServer;
  6184.  
  6185.       if not FSocketTalk.ServerResult then
  6186.       begin
  6187.  
  6188.         AllOk := False;
  6189.         Break;
  6190.       end;
  6191.     end;
  6192.  
  6193.     if AllOk then
  6194.     begin
  6195.  
  6196.       FSocketTalk.Talk('DATA'#13#10, #13#10, stData);
  6197.       FSocketTalk.WaitServer;
  6198.  
  6199.       if FSocketTalk.ServerResult then
  6200.       begin
  6201.  
  6202.         FSocketTalk.PacketSize := FPacketSize;
  6203.         FSocketTalk.Talk(StringReplace(Msg, _DATAEND1, _DATAEND2, [rfReplaceAll])+_DATAEND1, #13#10, stSendData);
  6204.         FSocketTalk.WaitServer;
  6205.  
  6206.         if FSocketTalk.ServerResult then
  6207.         begin
  6208.  
  6209.           Result := True;
  6210.         end;
  6211.       end;
  6212.     end;
  6213.   end;
  6214.  
  6215.   sDests.Free;
  6216. end;
  6217.  
  6218. // =============================================================================
  6219.  
  6220. begin
  6221.  
  6222.   Randomize;
  6223. end.
  6224.