home *** CD-ROM | disk | FTP | other *** search
/ Freelog 11 / Freelog011.iso / BestOf / PhoenixMail / Source / phoenix / ParserSup.pas < prev    next >
Pascal/Delphi Source File  |  1999-02-20  |  23KB  |  779 lines
  1. {*****************************************************************************
  2.  *
  3.  *  ParserSup.pas - E-mail Parser Support Routines (27-July-1998)
  4.  *
  5.  *  Copyright (c) 1998-99 Michael Haller
  6.  *
  7.  *  Author:     Michael Haller
  8.  *  E-mail:     michael@discountdrive.com
  9.  *  Homepage:   http://www.discountdrive.com/sunrise
  10.  *
  11.  *  This program is free software; you can redistribute it and/or
  12.  *  modify it under the terms of the GNU General Public License
  13.  *  as published by the Free Software Foundation;
  14.  *
  15.  *  This program is distributed in the hope that it will be useful,
  16.  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  17.  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18.  *  GNU General Public License for more details.
  19.  *
  20.  *  You should have received a copy of the GNU General Public License
  21.  *  along with this program; if not, write to the Free Software
  22.  *  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA
  23.  *
  24.  *----------------------------------------------------------------------------
  25.  *
  26.  *  Revision history:
  27.  *
  28.  *     DATE     REV                 DESCRIPTION
  29.  *  ----------- --- ----------------------------------------------------------
  30.  *
  31.  *****************************************************************************}
  32.  
  33. unit ParserSup;
  34.  
  35. interface
  36.  
  37. uses
  38.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  39.   Base64Sup, ComCtrls;
  40.  
  41. function SkipChar(S: String; C: Char): String;
  42. procedure CommataStringToStringList(S: String; var SL: TStringList);
  43. function StringListToCommataString(SL: TStringList; Decoded: Boolean): String;
  44. procedure SaveMIMEToFile(var SL: TStringList; ContentType, ContentEncoding: String);
  45. procedure GetFieldArguments(S: String; var S1, S2: String);
  46. procedure MakeFields(var SL: TStringList; ClearEmpties: Boolean);
  47. function GetContentType(Variable, ContentType: String): String;
  48. function FromQuotedPrintable(S: String): String;
  49. function ToQuotedPrintable(S: String): String;
  50. function GetMIMEFilename(Dir, ContentType: String): String;
  51. procedure GetMIMEType(Filename: String; var Content, Encoding: String; var Format: Byte);
  52. function GetMIMEHeaderField(Field: String): String;
  53. function SetMIMEHeaderField(Field: String): String;
  54. function BreakString(S: String): String;
  55. procedure AttachFileToTextfile(var F: Text; Filename: String; Format: Byte);
  56. procedure SkipSpaces(var S: String);
  57. function GetToken(var S: String): String;
  58. function ApplyFilter(Msg, Filter: String; var Points: Integer): Boolean;
  59. function GetUniqueMailName: String;
  60. function ExtractEMailAddress(S: String): String;
  61. function ExtractEMailName(S: String): String;
  62. procedure GetOutcomingMailFileList(Node: TTreeNode; var SL: TStringList);
  63. function StretchString(S: String; Count: Integer): String;
  64. function SkipSpacesAtEnd(S: String): String;
  65. function SoftLineBreak(S: String; Quoted: Boolean): String;
  66. function GetCommataStringReceiver: String;
  67. procedure SetPXTreeNodeName(Node: TTreeNode);
  68. function GetPXTreeNodeName(Node: TTreeNode): String;
  69.  
  70. implementation
  71.  
  72. uses
  73.   PXStuff, MailParser;
  74.  
  75. var
  76.   FT: Text;
  77.   FF: File;
  78.  
  79. procedure SetPXTreeNodeName(Node: TTreeNode);
  80. var
  81.   SearchRec: TSearchRec;
  82.   Found, Count, WholeCount: Integer;
  83.   Dir, Name: String;
  84.   B: Boolean;
  85. begin
  86.   if Node = nil then Exit;
  87.   if Node.StateIndex = 1 then begin
  88.     Dir := PAccountData(Node.Data)^.Path;
  89.     Name := PAccountData(Node.Data)^.Name;
  90.   end;
  91.   if Node.StateIndex = 2 then begin
  92.     Dir := PFolderData(Node.Data)^.Path;
  93.     Name := PFolderData(Node.Data)^.Name;
  94.   end;
  95.   if Node.StateIndex = 3 then begin
  96.     Dir := sTrashFolder;
  97.     Name := Node.Text;
  98.   end;
  99.   if Node.StateIndex = 4 then Exit;
  100.   if Node.StateIndex = 5 then begin
  101.     Dir := sRepositoryFolder;
  102.     Name := Node.Text;
  103.   end;
  104.   Screen.Cursor := crHourGlass;
  105.   Count := 0;
  106.   WholeCount := 0;
  107.   Found := FindFirst(Dir+'*.MSG', faAnyFile, SearchRec);
  108.   while Found = 0 do begin
  109.     if FileGetAttr(Dir+SearchRec.Name) and faArchive = 0 then Inc(Count);
  110.     Inc(WholeCount);
  111.     Found := FindNext(SearchRec);
  112.   end;
  113.   FindClose(SearchRec);
  114.   B := False;
  115.   if bShowCntInBrackets then begin
  116.     if (Count > 0) or (WholeCount > 0) then begin
  117.       Node.Text := Name + ' ('+IntToStr(Count)+'/'+IntToStr(WholeCount)+')';
  118.       B := True;
  119.     end;
  120.   end else begin
  121.     if Count > 0 then begin
  122.       Node.Text := Name + ' ('+IntToStr(Count)+')';
  123.       B := True;
  124.     end;
  125.   end;
  126.   if B = False then Node.Text := Name;
  127.   Screen.Cursor := crDefault;
  128. end;
  129.  
  130. function GetPXTreeNodeName(Node: TTreeNode): String;
  131. begin
  132.   if Node = nil then Exit;
  133.   if Node.StateIndex = 1 then Result := PAccountData(Node.Data)^.Name;
  134.   if Node.StateIndex = 2 then Result := PFolderData(Node.Data)^.Name;
  135.   if Node.StateIndex = 3 then Result := sTrashBagCaption;
  136.   if Node.StateIndex = 4 then Result := Node.Text;
  137.   if Node.StateIndex = 5 then Result := sRepositoryCaption;
  138. end;
  139.  
  140. function GetCommataStringReceiver: String;
  141. var
  142.   S, S1, S2, S3: String;
  143. begin
  144.   S1 := StringListToCommataString(CurrentEMail.ToReceiver, False);
  145.   S2 := StringListToCommataString(CurrentEMail.CC, False);
  146.   S3 := StringListToCommataString(CurrentEMail.BCC, False);
  147.   S := '';
  148.   if S1 <> '' then S := S1;
  149.   if S2 <> '' then if S = '' then S := S2 else S := S + ', ' + S2;
  150.   if S3 <> '' then if S = '' then S := S3 else S := S + ', ' + S3;
  151.   Result := S;
  152. end;
  153.  
  154. function SoftLineBreak(S: String; Quoted: Boolean): String;
  155. const
  156.   C = 76;
  157. var
  158.   I, E: Integer;
  159.   B: Boolean;
  160.  
  161.   function IsNotAlreadyQuoted: Boolean;
  162.   begin
  163.     Result := True;
  164.     if Length(S) > 0 then
  165.       if S[1] = '>' then Result := False;
  166.   end;
  167.  
  168. begin
  169.   Result := #13+#10+'*** Phoenix Mail Error: Lines have been cut off! ***'+#13+#10;
  170.   try
  171.     I := C;
  172.     if Quoted and IsNotAlreadyQuoted then S := '>' + S;
  173.     //while text longer than 76
  174.     while Length(S) > I do begin
  175.       B := False;
  176.       //Search space char
  177.       for E := I downto (I-C+2) do begin
  178.         if Ord(S[E]) <= 32 then begin
  179.           I := E+1;
  180.           B := True;
  181.           Break;
  182.         end;
  183.       end;
  184.       //found space char
  185.       if B then begin
  186.         if Quoted then begin
  187.           Insert(#13+#10+'>', S, I);
  188.           Inc(I, C+1);
  189.         end else begin
  190.           Insert(#13+#10, S, I);
  191.           Inc(I, C+1);
  192.         end;
  193.       end else begin
  194.         if Quoted then begin
  195.           Insert(#13+#10+'>', S, I+1);
  196.           Inc(I, C+1);
  197.         end else begin
  198.           Insert(#13+#10+#32, S, I+1);
  199.           Inc(I, C+1);
  200.         end;
  201.       end;
  202.     end;
  203.     Result := S;
  204.   except end;
  205. end;
  206.  
  207. procedure AttachFileToTextfile(var F: Text; Filename: String; Format: Byte);
  208. const
  209.   L = 57;
  210. var
  211.   S: String;
  212.   I, E, K: Integer;
  213.   FF: File;
  214. begin
  215.   SetFileAttr(Filename, False, True, False, False);
  216.   //Quoted printable
  217.   if Format = 0 then begin
  218.     AssignFile(FT, Filename);
  219.     Reset(FT);
  220.     while not EoF(FT) do begin
  221.       ReadLn(FT, S);
  222.       S := SoftLineBreak(ToQuotedPrintable(S), False);
  223.       WriteLn(F, S);
  224.     end;
  225.     CloseFile(FT);
  226.   end;
  227.   //Base64
  228.   if Format = 1 then begin
  229.     AssignFile(FF, Filename);
  230.     Reset(FF, 1);
  231.     E := Trunc(FileSize(FF) / L);
  232.     K := FileSize(FF) - (E * L);
  233.     SetLength(S, L);
  234.     for I := 1 to E do begin
  235.       BlockRead(FF, S[1], L);
  236.       WriteLn(F, StringToBase64(S));
  237.     end;
  238.     if K > 0 then begin
  239.       SetLength(S, K);
  240.       BlockRead(FF, S[1], K);
  241.       WriteLn(F, StringToBase64(S));
  242.     end;
  243.     CloseFile(FF);
  244.   end;
  245. end;
  246.  
  247. function BreakString(S: String): String;
  248. var
  249.   I: Integer;
  250. begin
  251.   I := 77;
  252.   while Length(S) > I do begin
  253.     Insert(#13+#10+#32, S, I);
  254.     Inc(I, 78);
  255.   end;
  256.   Result := S;
  257. end;
  258.  
  259. procedure SaveMIMEToFile(var SL: TStringList; ContentType, ContentEncoding: String);
  260. var
  261.   I: Integer;
  262.   S, T, G, H: String;
  263.   BL: TStringList;
  264. begin
  265.   S := GetContentType('name', ContentType);
  266.   S := SkipChar(S, '"');
  267.   T := LowerCase(GetContentType('', ContentEncoding));
  268.   G := LowerCase(GetContentType('', ContentType));
  269.   if T = '' then T := '7bit';
  270.   if G = '' then G := 'text/plain';
  271.   if S = '' then begin
  272.     if not FileExists(sTempMessageFile) then begin
  273.       CurrentEMail.MsgType := StandardMsgType;
  274.       if G = 'text/html' then begin CurrentEMail.MsgType := mtHtml; S := sTempMessageFile; end else
  275.       if G = 'text/plain' then begin CurrentEMail.MsgType := mtText; S := sTempMessageFile; end else
  276.       if G = 'text/richtext' then begin CurrentEMail.MsgType := mtRich; S := sTempMessageFile; end else
  277.       S := GetMIMEFilename(sTemporaryFolder, G);
  278.     end else
  279.       S := GetMIMEFilename(sTemporaryFolder, G);
  280.   end else
  281.     S := sTemporaryFolder+S;
  282.  
  283.   if (T = '7bit') or (T = '8bit') or (T = 'Binary') then begin
  284.     //Text file
  285.     AssignFile(FT, S);
  286.     Rewrite(FT);
  287.     for I := 0 to SL.Count-1 do begin
  288.       H := SL.Strings[I];
  289.       if (I = SL.Count-1) and (H = '') then Break;
  290.       WriteLn(FT, H);
  291.     end;
  292.     CloseFile(FT);
  293.   end;
  294.   if T = 'quoted-printable' then begin
  295.     //Quoted-printable text file
  296.     AssignFile(FT, S);
  297.     Rewrite(FT);
  298.     BL := TStringList.Create;
  299.     I := 0;
  300.     while I <= SL.Count-1 do begin
  301.       H := SL.Strings[I];
  302.       if (H <> '') and (H[Length(H)] = '=') then begin
  303.         Delete(H, Length(H), 1);
  304.         if I < SL.Count-1 then begin
  305.           H := H + SL.Strings[I+1];
  306.           Inc(I);
  307.         end;
  308.       end;
  309.       H := FromQuotedPrintable(H);
  310.       if (I = SL.Count-1) and (H = '') then Break;
  311.       WriteLn(FT, H);
  312.       Inc(I);
  313.     end;
  314.     SL.Clear;
  315.     SL.Assign(BL);
  316.     BL.Free;
  317.     {for I := 0 to SL.Count-1 do begin
  318.       H := FromQuotedPrintable(SL.Strings[I]);
  319.       if (I = SL.Count-1) and (H = '') then Break;
  320.       WriteLn(FT, H);
  321.     end;  }
  322.     CloseFile(FT);
  323.   end;
  324.   if T = 'base64' then begin
  325.     //BASE64 binary file
  326.     AssignFile(FF, S);
  327.     Rewrite(FF, 1);
  328.     for I := 0 to SL.Count-1 do
  329.       if SL.Strings[I] <> '' then begin
  330.         G := Base64ToString(SL.Strings[I]);
  331.         BlockWrite(FF, G[1], Length(G));
  332.       end;
  333.     CloseFile(FF);
  334.   end;
  335. end;
  336.  
  337. procedure GetMIMEType(Filename: String; var Content, Encoding: String; var Format: Byte);
  338. var
  339.   S: String;
  340. begin
  341.   S := ExtractFileExt(ExtractFilename(Filename));
  342.   if S = '.txt' then begin Content := 'text/txt; charset=ISO-8859-1'; Encoding := 'Quoted-printable'; Format := 0; end else
  343.   if S = '.rtf' then begin Content := 'text/rtf; charset=ISO-8859-1'; Encoding := 'Quoted-printable'; Format := 0; end else
  344.   if S = '.htm' then begin Content := 'text/htm; charset=ISO-8859-1'; Encoding := 'Quoted-printable'; Format := 0; end else
  345.   if S = '.html' then begin Content := 'text/html'; Encoding := 'BASE64'; Format := 1; end else
  346.   if S = '.pdf' then begin Content := 'application/pdf'; Encoding := 'BASE64'; Format := 1; end else
  347.   if S = '.zip' then begin Content := 'application/zip'; Encoding := 'BASE64'; Format := 1; end else
  348.   if S = '.doc' then begin Content := 'application/msword'; Encoding := 'BASE64'; Format := 1; end else
  349.   if S = '.bmp' then begin Content := 'application/x-bmp'; Encoding := 'BASE64'; Format := 1; end else
  350.   if S = '.jpg' then begin Content := 'application/jpeg'; Encoding := 'BASE64'; Format := 1; end else
  351.   if S = '.jpeg' then begin Content := 'application/jpeg'; Encoding := 'BASE64'; Format := 1; end else
  352.   if S = '.gif' then begin Content := 'image/gif'; Encoding := 'BASE64'; Format := 1; end else
  353.   if S = '.ief' then begin Content := 'image/ief'; Encoding := 'BASE64'; Format := 1; end else
  354.   if S = '.tif' then begin Content := 'image/tiff'; Encoding := 'BASE64'; Format := 1; end else
  355.   if S = '.tiff' then begin Content := 'image/tiff'; Encoding := 'BASE64'; Format := 1; end else
  356.   if S = '.mov' then begin Content := 'video/quicktime'; Encoding := 'BASE64'; Format := 1; end else
  357.     begin Content := 'application/octet-stream'; Encoding := 'BASE64'; Format := 1; end;
  358.   Content := Content+'; Name='+ExtractFilename(Filename);
  359. end;
  360.  
  361. function GetMIMEFilename(Dir, ContentType: String): String;
  362. var
  363.   I: Integer;
  364.   S: String;
  365. begin
  366.   S := LowerCase(GetContentType('', ContentType));
  367.   if S = 'text/plain' then S := 'txt' else
  368.   if S = 'text/richtext' then S := 'rtf' else
  369.   if S = 'text/html' then S := 'htm' else
  370.   if S = 'message/rfc822' then S := 'msg' else
  371.   if S = 'message/partial' then S := 'txt' else
  372.   if S = 'message/external-body' then S := 'txt' else
  373.   if S = 'message/news' then S := 'msg' else
  374.   if S = 'application/rtf' then S := 'rtf' else
  375.   if S = 'application/pdf' then S := 'pdf' else
  376.   if S = 'application/zip' then S := 'zip' else
  377.   if S = 'application/msword' then S := 'doc' else
  378.   if S = 'application/x-bmp' then S := 'bmp' else
  379.   if S = 'image/jpeg' then S := 'jpg' else
  380.   if S = 'image/gif' then S := 'gif' else
  381.   if S = 'image/ief' then S := 'ief' else
  382.   if S = 'image/tiff' then S := 'tif' else
  383.   if S = 'video/mpeg' then S := 'mpg' else
  384.   if S = 'video/quicktime' then S := 'mov' else
  385.   if S = 'multipart/parallel' then S := 'txt' else
  386.   if S = 'multipart/alternative' then S := 'txt' else
  387.     S := 'bin';
  388.   I := 0;
  389.   while FileExists(Dir+'Noname'+IntToStr(I)+'.'+S) do
  390.     Inc(I);
  391.   Result := Dir+'Noname'+IntToStr(I)+'.'+S;
  392. end;
  393.  
  394. function GetMIMEHeaderField(Field: String): String;
  395. var
  396.   I, E: Integer;
  397.   S1, S2, S3: String;
  398. begin
  399.   Result := '';
  400.   S3 := Field;
  401.   try
  402.     while Pos('=?', Field) > 0 do begin
  403.       //Find =?
  404.       I := Pos('=?', Field);
  405.       Result := Result + Copy(Field, 1, I-1);
  406.       Delete(Field, 1, I+1);
  407.       //find ?Q?
  408.       I := Pos('?', Field);
  409.       S1 := Field[I+1];
  410.       Delete(Field, 1, I+2);
  411.       //find ?=
  412.       I := Pos('?=', Field);
  413.       S2 := Copy(Field, 1, I-1);
  414.       Delete(Field, 1, I+1);
  415.       //encode
  416.       if UpperCase(S1) = 'Q' then begin
  417.         S2 := FromQuotedPrintable(S2);
  418.         for E := 1 to Length(S2) do
  419.           if S2[E] = '_' then S2[E] := ' ';
  420.       end else begin
  421.         S2 := Base64ToString(S2);
  422.       end;
  423.       Result := Result + S2;
  424.     end;
  425.     Result := Result + Field;
  426.   except
  427.     Result := S3;
  428.   end;
  429. end;
  430.  
  431. function SetMIMEHeaderField(Field: String): String;
  432. var
  433.   I: Integer;
  434.   S1, S2: String;
  435.   B: Boolean;
  436. begin
  437.   Result := Field;
  438.   B := False;
  439.   for I := 1 to Length(Field) do
  440.     if Ord(Field[I]) > 127 then B := True;
  441.   if B then begin
  442.     I := Pos('<', Field);
  443.     S2 := ''; S1 := '';
  444.     if I > 0 then begin
  445.       S1 := Copy(Field, 1, I-1);
  446.       S2 := Copy(Field, I, Length(Field)-I+1);
  447.     end else
  448.       S1 := Field;
  449.     Result := '=?ISO-8859-1?Q?'+ToQuotedPrintable(S1)+'?='+S2;
  450.   end;
  451. end;
  452.  
  453. function FromQuotedPrintable(S: String): String;
  454. var
  455.   I, E: Integer;
  456. begin
  457.   I := 1;
  458.   Result := '';
  459.   while I <= Length(S) do begin
  460.     if (S[I] = '=') and (I < Length(S)-1) then begin
  461.       E := HexToInt(S[I+1]+S[I+2]);
  462.       Inc(I, 3);
  463.       Result := Result+Chr(E);
  464.     end else begin
  465.       Result := Result+S[I];
  466.       Inc(I);
  467.     end;
  468.   end;
  469. end;
  470.  
  471. function ToQuotedPrintable(S: String): String;
  472. var
  473.   I: Integer;
  474. begin
  475.   Result := '';
  476.   for I := 1 to Length(S) do
  477.     if (Ord(S[I]) > 127) or (S[I] = '?') or (S[I] = '=') then
  478.       Result := Result+'='+IntToHex(Ord(S[I]), 2)
  479.     else
  480.       Result := Result+S[I];
  481. end;
  482.  
  483. procedure GetFieldArguments(S: String; var S1, S2: String);
  484. var
  485.   E: Integer;
  486. begin
  487.   // parse line in S1 and S2 and the ':' between them
  488.   E := Pos(':', S);
  489.   S1 := Copy(S, 0, E-1);
  490.   while (Length(S1) > 0) and (S1[1] = ' ') do Delete(S1, 1, 1);
  491.   S2 := Copy(S, E+1, Length(S)-E);
  492.   while (Length(S2) > 0) and (S2[1] = ' ') do Delete(S2, 1, 1);
  493.   S2 := GetMIMEHeaderField(S2);
  494. end;
  495.  
  496. procedure MakeFields(var SL: TStringList; ClearEmpties: Boolean);
  497. var
  498.   H: TStringList;
  499.   I, E: Integer;
  500.   S: String;
  501. begin
  502.   H := TStringList.Create;
  503.   I := -1;
  504.   for E := 0 to SL.Count-1 do begin
  505.     S := SL.Strings[E];
  506.     if ClearEmpties = True then begin
  507.       if S <> '' then begin                // if not empty line
  508.         if S[1] in [#32, #9] then begin    // if Tab or Space
  509.           Delete(S, 1, 1);                 // manual linebreak
  510.           if I = -1 then I := H.Add('');    // add to previous line
  511.           H[I] := H[I]+S;
  512.         end else                           // if normal line
  513.           I := H.Add(S);
  514.       end;
  515.     end;
  516.     if ClearEmpties = False then begin
  517.       if (Length(S) > 1) and (S[1] in [#32, #9]) then begin    // if Tab or Space
  518.         Delete(S, 1, 1);                 // manual linebreak
  519.         if I = -1 then I := H.Add('');    // add to previous line
  520.         H[I] := H[I]+S;
  521.       end else                          // if normal line
  522.         I := H.Add(S);
  523.     end;
  524.   end;
  525.   SL.Clear;
  526.   SL.Assign(H);
  527.   H.Free;
  528. end;
  529.  
  530. function GetContentType(Variable, ContentType: String): String;
  531. var
  532.   I: Integer;
  533.   S: String;
  534. begin
  535.   Result := '';
  536.   SkipChar(ContentType, ' ');
  537.   I := 1; S := '';
  538.   while (I <= Length(ContentType)) and (ContentType[I] <> ';') do begin
  539.     S := S + ContentType[I];
  540.     Inc(I);
  541.   end;
  542.   if Variable = '' then begin
  543.     Result := S;
  544.     Exit;
  545.   end;
  546.   I := Pos(Lowercase(Variable), LowerCase(ContentType));
  547.   if I = 0 then Exit;
  548.   Delete(ContentType, 1, I+Length(Variable));
  549.   I := Pos(';', ContentType);
  550.   if I = 0 then I := Length(ContentType)+1;
  551.   Result := Copy(ContentType, 1, I-1);
  552. end;
  553.  
  554. function SkipChar(S: String; C: Char): String;
  555. var
  556.   I: Integer;
  557. begin
  558.   Result := '';
  559.   for I := 1 to Length(S) do
  560.     if S[I] <> C then
  561.       Result := Result + S[I];
  562. end;
  563.  
  564. procedure CommataStringToStringList(S: String; var SL: TStringList);
  565. var
  566.   T: String;
  567.   I: Integer;
  568. begin
  569.   SL.Clear;
  570.   T := '';
  571.   S := S+',';
  572.   for I := 1 to Length(S) do
  573.     if S[I] = ',' then begin
  574.       if Length(T) > 1 then while (T[1] = ' ') or (T[1] = #9) do Delete(T, 1, 1);
  575.       T := GetMIMEHeaderField(T);
  576.       if T <> '' then SL.Add(T);
  577.       T := '';
  578.     end else begin
  579.       if S[I] <> '"' then T := T+S[I];
  580.     end;
  581. end;
  582.  
  583. function StringListToCommataString(SL: TStringList; Decoded: Boolean): String;
  584. var
  585.   S: String;
  586.   I, E: Integer;
  587. begin
  588.   S := '';
  589.   E := 0;
  590.   for I := 0 to SL.Count-1 do
  591.     if SL.Strings[I] <> '' then begin
  592.       if Decoded then SL.Strings[I] := SetMIMEHeaderField(SL.Strings[I]);
  593.       if E = 0 then
  594.         S := S+SL.Strings[I]
  595.       else
  596.         S := S+', '+SL.Strings[I];
  597.       Inc(E);
  598.     end;
  599.   Result := S;
  600. end;
  601.  
  602. procedure SkipSpaces(var S: String);
  603. begin
  604.   while (Length(S) > 1) and ((S[1] = #32) or (S[1] = #9)) do
  605.     Delete(S, 1, 1);
  606. end;
  607.  
  608. function GetToken(var S: String): String;
  609. var
  610.   I: Integer;
  611. begin
  612.   SkipSpaces(S);
  613.   Result := '';
  614.   I := 1;
  615.   while (I <= Length(S)) and (S[I] <> #32) and (S[I] <> #9) do begin
  616.     Result := Result+S[I];
  617.     Inc(I);
  618.   end;
  619.   Delete(S, 1, I-1);
  620. end;
  621.  
  622. function ApplyFilter(Msg, Filter: String; var Points: Integer): Boolean;
  623. var
  624.   SL: TStringList;
  625.   S, LMsg: String;
  626.   C: Char;
  627.   I: Integer;
  628.   B: Boolean;
  629.  
  630. {   1 = normal
  631.     2 = plus
  632.     3 = minus
  633.     4 = normal quoted
  634.     5 = plus quoted
  635.     6 = minus quoted     }
  636.  
  637.   function ExtractQuoted(var S: String): Boolean;
  638.   begin
  639.     Result := False;
  640.     if S[1] = '"' then begin
  641.       Delete(S, 1, 1);
  642.       Filter := S + Filter;
  643.       S := '';
  644.       I := 1;
  645.       while (I <= Length(Filter)) and (Filter[I] <> '"') do begin
  646.         S := S+Filter[I];
  647.         Inc(I);
  648.       end;
  649.       Delete(Filter, 1, I);
  650.       Result := True;
  651.     end;
  652.   end;
  653.  
  654. begin
  655.   Points := 0;
  656.   if Filter = '' then begin Result := True; Exit; end;
  657.   SL := TStringList.Create;
  658.   S := GetToken(Filter);
  659.   while S <> '' do begin
  660.     if S[1] = '+' then begin
  661.       Delete(S, 1, 1);
  662.       if ExtractQuoted(S) then SL.Add('5'+S) else
  663.         SL.Add(LowerCase('2'+S));
  664.     end else
  665.     if S[1] = '-' then begin
  666.       Delete(S, 1, 1);
  667.       if ExtractQuoted(S) then SL.Add('6'+S) else
  668.         SL.Add(LowerCase('3'+S));
  669.     end else begin
  670.       if ExtractQuoted(S) then SL.Add('4'+S) else
  671.         SL.Add(LowerCase('1'+S));
  672.     end;
  673.     S := GetToken(Filter);
  674.   end;
  675.  
  676.   LMsg := LowerCase(Msg);
  677.   B := True;
  678.   Points := 0;
  679.   for I := 0 to SL.Count-1 do begin
  680.     S := SL.Strings[I];
  681.     C := S[1];
  682.     Delete(S, 1, 1);
  683.     if C = '1' then
  684.         if Pos(S, LMsg) > 0 then Inc(Points);
  685.     if C = '2' then
  686.         if Pos(S, LMsg) = 0 then B := False else Inc(Points);
  687.     if C = '3' then
  688.         if Pos(S, LMsg) > 0 then B := False else Inc(Points);
  689.     if C = '4' then
  690.       if Pos(S, Msg) > 0 then Inc(Points);
  691.     if C = '5' then
  692.         if Pos(S, Msg) = 0 then B := False else Inc(Points);
  693.     if C = '6' then
  694.         if Pos(S, Msg) > 0 then B := False else Inc(Points);
  695.   end;
  696.  
  697.   if B = False then Points := -1;
  698.   Result := B;
  699.   SL.Free;
  700. end;
  701.  
  702. function GetUniqueMailName: String;
  703. var
  704.   Ho, Mi, Se, Ms: Word;
  705. begin
  706.   DecodeTime(Time, Ho, Mi, Se, Ms);
  707.   Result := Chr(Random(26)+97) + Chr(Random(26)+97) +
  708.             IntToStr(Mi) + IntToStr(Se) + IntToStr(Random(100));
  709. end;
  710.  
  711. function ExtractEMailAddress(S: String): String;
  712. var
  713.   I, E: Integer;
  714. begin
  715.   Result := S;
  716.   I := Pos('<', S);
  717.   E := Pos('>', S);
  718.   if (I = 0) or (E = 0) then Exit;
  719.   Result := Copy(S, I+1, E-I-1);
  720. end;
  721.  
  722. function ExtractEMailName(S: String): String;
  723. var
  724.   I, E: Integer;
  725. begin
  726.   Result := '';
  727.   I := Pos('<', S);
  728.   E := Pos('>', S);
  729.   if (I = 0) or (E = 0) then Exit;
  730.   Result := Copy(S, 1, I-1);
  731. end;
  732.  
  733. procedure GetOutcomingMailFileList(Node: TTreeNode; var SL: TStringList);
  734.  
  735.   procedure GetFiles(Dir: String);
  736.   var
  737.     SearchRec: TSearchRec;
  738.     Found: Integer;
  739.   begin
  740.     Found := FindFirst(Dir+'*.msg', faAnyFile, SearchRec);
  741.     while Found = 0 do begin
  742.       SL.Add(Dir+SearchRec.Name);
  743.       Found := FindNext(SearchRec);
  744.     end;
  745.     FindClose(SearchRec);
  746.   end;
  747.  
  748.   procedure GetSubNotes(Node: TTreeNode);
  749.   var
  750.     I: Integer;
  751.   begin
  752.     for I := 0 to Node.Count-1 do begin
  753.       if PFolderData(Node.Item[I].Data)^.OutBox then
  754.         GetFiles(PFolderData(Node.Item[I].Data)^.Path);
  755.       if Node.Count > 0 then GetSubNotes(Node.Item[I]);
  756.     end;
  757.   end;
  758.  
  759. begin
  760.   GetSubNotes(Node);
  761. end;
  762.  
  763. function StretchString(S: String; Count: Integer): String;
  764. begin
  765.   Result := S;
  766.   while Length(Result) < Count do Result := Result+' ';
  767. end;
  768.  
  769. function SkipSpacesAtEnd(S: String): String;
  770. var
  771.   I: Integer;
  772. begin
  773.   I := Length(S);
  774.   while (I > 0) and (S[I] = ' ') do begin Dec(I); SetLength(S, I); end;
  775.   Result := S;
  776. end;
  777.  
  778. end.
  779.