Mail2000.pas
上传用户:yjb1804
上传日期:2021-01-30
资源大小:3105k
文件大小:158k
源码类别:

Email服务器

开发平台:

Delphi

  1.   if FIsDecoded then
  2.     Exit;
  3.   FIsDecoded := True;
  4.   if FBody.Size = 0 then Exit;
  5.   Content := GetAttachInfo;
  6.   Encoding := LowerCase(GetLabelValue(_C_TE));
  7.   FDecoded.Clear;
  8.   if Encoding = _E_QP then
  9.   begin
  10.     GetMem(Buffer, FBody.Size+1);
  11.     StrLCopy(Buffer, FBody.Memory, FBody.Size);
  12.     Buffer[FBody.Size] := #0;
  13.     DecoLine := DecodeQuotedPrintable(Buffer);
  14.     FreeMem(Buffer);
  15.     GetMem(Buffer, Length(DecoLine)+1);
  16.     StrPCopy(Buffer, DecoLine);
  17.     FDecoded.Write(Buffer^, Length(DecoLine));
  18.     FreeMem(Buffer);
  19.   end
  20.   else
  21.   begin
  22.     if Encoding = _E_BA then
  23.     begin
  24.       nPos := 1;
  25.       SetLength(Data, FBody.Size);
  26.       FBody.Position := 0;
  27.       FBody.ReadBuffer(Data[1], FBody.Size);
  28.       while nPos >= 0 do
  29.       begin
  30.         DataLine(Data, DecoLine, nPos);
  31.         GetMem(Buffer, 132);
  32.         Size := DecodeLineBASE64(TrimSpace(DecoLine), Buffer);
  33.         if Size > 0 then
  34.           FDecoded.Write(Buffer^, Size);
  35.         FreeMem(Buffer);
  36.       end;
  37.     end
  38.     else
  39.     begin
  40.       if (Encoding = _E_UU) or (Encoding = _E_XU) then
  41.       begin
  42.         nPos := 1;
  43.         SetLength(Data, FBody.Size);
  44.         FBody.Position := 0;
  45.         FBody.ReadBuffer(Data[1], FBody.Size);
  46.         while nPos >= 0 do
  47.         begin
  48.           DataLine(Data, DecoLine, nPos);
  49.           GetMem(Buffer, 80);
  50.           Size := DecodeLineUUCODE(TrimSpace(DecoLine), Buffer);
  51.           FDecoded.Write(Buffer^, Size);
  52.           FreeMem(Buffer);
  53.         end;
  54.         EncodeBinary; // Convert to base64
  55.       end
  56.       else
  57.       begin
  58.         // 7bit, 8bit, binary and any other
  59.         GetMem(Buffer, FBody.Size);
  60.         FBody.Position := 0;
  61.         FBody.Read(Buffer^, FBody.Size);
  62.         FDecoded.Write(Buffer^, FBody.Size);
  63.         FreeMem(Buffer);
  64.       end;
  65.     end;
  66.   end;
  67. end;
  68. // Encode mail part
  69. procedure TMailPart.Encode(const ET: TEncodingType);
  70. begin
  71.   case ET of
  72.     etBase64: EncodeBinary;
  73.     etQuotedPrintable: EncodeText;
  74.     etNoEncoding:
  75.     begin
  76.       FDecoded.Position := 0;
  77.       FBody.Clear;
  78.       FBody.LoadFromStream(FDecoded);
  79.       SetLabelValue(_C_TE, '');
  80.     end;
  81.   end;
  82. end;
  83. // Encode mail part in quoted-printable
  84. procedure TMailPart.EncodeText;
  85. var
  86.   Buffer: String;
  87.   Encoded: String;
  88. begin
  89.   FBody.Clear;
  90.   SetLabelValue(_C_TE, _E_QP);
  91.   if FDecoded.Size > 0 then
  92.   begin
  93.     SetLength(Buffer, FDecoded.Size);
  94.     FDecoded.Position := 0;
  95.     FDecoded.ReadBuffer(Buffer[1], FDecoded.Size);
  96.     Encoded := EncodeQuotedPrintable(Buffer, False);
  97.     FBody.Write(Encoded[1], Length(Encoded));
  98.   end;
  99. end;
  100. // Encode mail part in base64
  101. procedure TMailPart.EncodeBinary;
  102. begin
  103.   EncodeBASE64(FBody, FDecoded);
  104.   SetLabelValue(_C_TE, _E_BA);
  105. end;
  106. { TMailPartList ============================================================== }
  107. // Retrieve an item from the list
  108. function TMailPartList.Get(const Index: Integer): TMailPart;
  109. begin
  110. Result := inherited Items[Index];
  111. end;
  112. // Finalize MailPartList
  113. destructor TMailPartList.Destroy;
  114. begin
  115.   inherited Destroy;
  116. end;
  117. { TMailRecipients ================================================================ }
  118. // Initialize MailRecipients
  119. constructor TMailRecipients.Create(MailMessage: TMailMessage2000; Field: String);
  120. begin
  121.   inherited Create;
  122.   FMessage := MailMessage;
  123.   FField := Field;
  124.   FNames := TStringList.Create;
  125.   FAddresses := TStringList.Create;
  126.   FCheck := -1;
  127. end;
  128. // Finalize MailRecipients
  129. destructor TMailRecipients.Destroy;
  130. begin
  131.   FNames.Free;
  132.   FAddresses.Free;
  133.   inherited Destroy;
  134. end;
  135. // Copy recipients to temporary string list
  136. procedure TMailRecipients.HeaderToStrings;
  137. var
  138.   Dests: String;
  139.   Loop, Occur, PL: Integer;
  140.   Quote: Boolean;
  141.   EndQuote: Char;
  142.   IsName: Boolean;
  143.   sName: String;
  144.   sAddress: String;
  145. begin
  146.   if Length(FMessage.FHeader.Text) = FCheck then
  147.     Exit;
  148.   Occur := 0;
  149.   PL := SearchStringList(FMessage.FHeader, FField+':', Occur);
  150.   FNames.Clear;
  151.   FAddresses.Clear;
  152.   while PL >= 0 do
  153.   begin
  154.     Dests := LabelValue(FMessage.FHeader[PL]);
  155.     FCheck := Length(FMessage.FHeader.Text);
  156.     sName := '';
  157.     sAddress := '';
  158.     Quote := False;
  159.     EndQuote := #0;
  160.     IsName := True;
  161.     for Loop := 1 to Length(Dests) do
  162.     begin
  163.       if ((not Quote) and (Dests[Loop] in ['"', '(']))
  164.       or (Quote and (Dests[Loop] = EndQuote)) then
  165.       begin
  166.         case Dests[Loop] of
  167.           '"': EndQuote := '"';
  168.           '(': EndQuote := ')';
  169.         end;
  170.         Quote := not Quote;
  171.         if Quote and IsName and (sName <> '') and (sAddress = '') then
  172.         begin
  173.           sAddress := TrimSpace(sName);
  174.           sName := '';
  175.         end;
  176.       end
  177.       else
  178.       begin
  179.         if (not Quote) and (Dests[Loop] in [',', ';']) then
  180.         begin
  181.           if sAddress = '' then
  182.           begin
  183.             FNames.Add('');
  184.             FAddresses.Add(TrimSpace(sName));
  185.           end
  186.           else
  187.           begin
  188.             FNames.Add(DecodeLine7Bit(TrimSpace(sName)));
  189.             FAddresses.Add(TrimSpace(sAddress));
  190.           end;
  191.           sName := '';
  192.           sAddress := '';
  193.           IsName := True;
  194.         end;
  195.         if IsName then
  196.         begin
  197.           if Quote then
  198.             sName := sName + Dests[Loop]
  199.           else
  200.             if not (Dests[Loop] in [',', ';', '<', '>']) then
  201.               sName := sName + Dests[Loop];
  202.         end
  203.         else
  204.         begin
  205.           if (not Quote) and (not (Dests[Loop] in [',', ';', '<', '>', #32])) then
  206.             sAddress := sAddress + Dests[Loop];
  207.         end;
  208.         if (not Quote) and (Dests[Loop] = '<') then
  209.           IsName := False;
  210.         if (not Quote) and (Dests[Loop] = '>') then
  211.           IsName := True;
  212.         if Quote and (sAddress <> '') then
  213.           IsName := True;
  214.       end;
  215.     end;
  216.     if Dests <> '' then
  217.     begin
  218.       if sAddress = '' then
  219.       begin
  220.         FNames.Add('');
  221.         FAddresses.Add(TrimSpace(sName));
  222.       end
  223.       else
  224.       begin
  225.         FNames.Add(DecodeLine7Bit(TrimSpace(sName)));
  226.         FAddresses.Add(TrimSpace(sAddress));
  227.       end;
  228.     end;
  229.     Inc(Occur);
  230.     PL := SearchStringList(FMessage.FHeader, FField+':', Occur);
  231.   end;
  232. end;
  233. // Replace recipients with temporary string list
  234. procedure TMailRecipients.StringsToHeader;
  235. var
  236.   Dests: String;
  237.   Loop: Integer;
  238. begin
  239.   repeat
  240.     FMessage.SetLabelValue(FField, '');
  241.   until SearchStringList(FMessage.FHeader, FField+':') < 0;
  242.   if FAddresses.Count > 0 then
  243.   begin
  244.     Dests := '';
  245.     for Loop := 0 to FAddresses.Count-1 do
  246.     begin
  247.       if TrimSpace(FNames[Loop]) <> '' then
  248.         Dests := Dests+'"'+EncodeLine7Bit(TrimSpace(FNames[Loop]), FMessage.FCharSet)+'"'#32'<'+TrimSpace(FAddresses[Loop])+'>'
  249.       else
  250.         Dests := Dests+'<'+TrimSpace(FAddresses[Loop])+'>';
  251.       if Loop < FAddresses.Count-1 then
  252.         Dests := Dests+','#32;
  253.     end;
  254.     FMessage.SetLabelValue(FField, Dests);
  255.   end
  256.   else
  257.   begin
  258.     FMessage.SetLabelValue(FField, '');
  259.   end;
  260.   FCheck := Length(FMessage.FHeader.Text);
  261. end;
  262. // Retrieve a name by index
  263. function TMailRecipients.GetName(const Index: Integer): String;
  264. begin
  265.   HeaderToStrings;
  266.   Result := FNames[Index];
  267. end;
  268. // Retrieve a address by index
  269. function TMailRecipients.GetAddress(const Index: Integer): String;
  270. begin
  271.   HeaderToStrings;
  272.   Result := FAddresses[Index];
  273. end;
  274. // Returns number of recipients
  275. function TMailRecipients.GetCount: Integer;
  276. begin
  277.   HeaderToStrings;
  278.   Result := FAddresses.Count;
  279. end;
  280. // Replace a name by index
  281. procedure TMailRecipients.SetName(const Index: Integer; const Name: String);
  282. begin
  283.   HeaderToStrings;
  284.   FNames[Index] := Name;
  285.   StringsToHeader;
  286. end;
  287. // Replace an address by index
  288. procedure TMailRecipients.SetAddress(const Index: Integer; const Address: String);
  289. begin
  290.   HeaderToStrings;
  291.   FAddresses[Index] := Address;
  292.   StringsToHeader;
  293. end;
  294. // Find an recipient by name
  295. function TMailRecipients.FindName(const Name: String): Integer;
  296. begin
  297.   HeaderToStrings;
  298.   Result := SearchStringList(FNames, Name);
  299. end;
  300. // Find an recipient by address
  301. function TMailRecipients.FindAddress(const Address: String): Integer;
  302. begin
  303.   HeaderToStrings;
  304.   Result := SearchStringList(FAddresses, Address);
  305. end;
  306. // Put all names on commatext
  307. function TMailRecipients.GetAllNames: String;
  308. begin
  309.   HeaderToStrings;
  310.   Result := FNames.CommaText;
  311. end;
  312. // Put all addresses on commatext
  313. function TMailRecipients.GetAllAddresses: String;
  314. begin
  315.   HeaderToStrings;
  316.   Result := FAddresses.CommaText;
  317. end;
  318. // Set all recipients from commatext
  319. procedure TMailRecipients.SetAll(const Names, Addresses: String);
  320. begin
  321.   FNames.CommaText := Names + ',';
  322.   FAddresses.CommaText := Addresses + ',';
  323.   FCheck := -1;
  324.   while FNames.Count < FAddresses.Count do
  325.     FNames.Add('');
  326.   while FAddresses.Count < FNames.Count do
  327.     FNames.Delete(FNames.Count-1);
  328.   StringsToHeader;
  329. end;
  330. // Add recipient names to TStrings
  331. procedure TMailRecipients.AddNamesTo(const Str: TStrings);
  332. begin
  333.   HeaderToStrings;
  334.   Str.AddStrings(FNames);
  335. end;
  336. // Add recipient addresses to TStrings
  337. procedure TMailRecipients.AddAddressesTo(const Str: TStrings);
  338. begin
  339.   HeaderToStrings;
  340.   Str.AddStrings(FAddresses);
  341. end;
  342. // Add a new recipient
  343. procedure TMailRecipients.Add(const Name, Address: String);
  344. begin
  345.   HeaderToStrings;
  346.   FNames.Add(Name);
  347.   FAddresses.Add(Address);
  348.   StringsToHeader;
  349. end;
  350. // Replace an recipient by index
  351. procedure TMailRecipients.Replace(const Index: Integer; const Name, Address: String);
  352. begin
  353.   HeaderToStrings;
  354.   FNames[Index] := Name;
  355.   FAddresses[Index] := Address;
  356.   StringsToHeader;
  357. end;
  358. // Delete an recipient by index
  359. procedure TMailRecipients.Delete(const Index: Integer);
  360. begin
  361.   HeaderToStrings;
  362.   FNames.Delete(Index);
  363.   FAddresses.Delete(Index);
  364.   StringsToHeader;
  365. end;
  366. // Delete all recipients
  367. procedure TMailRecipients.Clear;
  368. begin
  369.   FNames.Clear;
  370.   FAddresses.Clear;
  371.   FMessage.SetLabelValue(FField, '');
  372.   FCheck := Length(FMessage.FHeader.Text);
  373. end;
  374. { TMailMessage2000 =============================================================== }
  375. // Initialize MailMessage
  376. constructor TMailMessage2000.Create(AOwner: TComponent);
  377. begin
  378.   inherited Create(AOwner);
  379.   FAttachList := TMailPartList.Create;
  380.   FTextPlain := TStringList.Create;
  381.   FTextHTML := TStringList.Create;
  382.   FTextPlainPart := nil;
  383.   FTextHTMLPart := nil;
  384.   FMixedPart := nil;
  385.   FRelatedPart := nil;
  386.   FAlternativePart := nil;
  387.   FNeedRebuild := False;
  388.   FNeedNormalize := False;
  389.   FNeedFindParts := False;
  390.   FCharset := _CHARSET;
  391.   FNameCount := 0;
  392.   FOwnerMessage := Self;
  393.   FToList := TMailRecipients.Create(Self, 'To');
  394.   FCcList := TMailRecipients.Create(Self, 'Cc');
  395.   FBccList := TMailRecipients.Create(Self, 'Bcc');
  396.   FTextEncoding := etQuotedPrintable;
  397.   FAttachEncoding := etBase64;
  398.   FEmbedMethod := emContentLocation;
  399.   FContentLocationBase := 'http://localhost/';
  400. end;
  401. // Finalize MailMessage
  402. destructor TMailMessage2000.Destroy;
  403. begin
  404.   inherited Destroy;
  405.   FAttachList.Free;
  406.   FTextPlain.Free;
  407.   FTextHTML.Free;
  408.   FToList.Free;
  409.   FCcList.Free;
  410.   FBccList.Free;
  411. end;
  412. // Get a dest. name from a field
  413. procedure TMailMessage2000.GetSenderData(const Field: String; var Name, Address: String);
  414. var
  415.   Dests: String;
  416.   Loop: Integer;
  417.   Quote: Boolean;
  418.   Unknown: String;
  419.   EndQuote, Phase: Char;
  420. begin
  421.   Dests := TrimSpace(GetLabelValue(Field));
  422.   Name := '';
  423.   Address := '';
  424.   Unknown := '';
  425.   Quote := False;
  426.   EndQuote := #0;
  427.   Phase := 'U';
  428.   for Loop := 1 to Length(Dests) do
  429.   begin
  430.     if ((not Quote) and (Dests[Loop] in ['"', '(']))
  431.     or (Quote and (Dests[Loop] = EndQuote)) then
  432.     begin
  433.       case Dests[Loop] of
  434.         '"': EndQuote := '"';
  435.         '(': EndQuote := ')';
  436.       end;
  437.       Quote := not Quote;
  438.       if Quote then
  439.       begin
  440.         if Phase = 'U' then
  441.           Address := Unknown;
  442.         Phase := 'N';
  443.       end
  444.       else
  445.       begin
  446.         Phase := 'A';
  447.       end;
  448.     end
  449.     else
  450.     begin
  451.       if (not Quote) and (Dests[Loop] = '<') then
  452.       begin
  453.         if Phase = 'U' then
  454.           Name := Unknown;
  455.           
  456.         Phase := 'A';
  457.       end
  458.       else
  459.       begin
  460.         if (not Quote) and (Dests[Loop] = '>') then
  461.         begin
  462.           Phase := 'N';
  463.         end
  464.         else
  465.         begin
  466.           if Phase = 'A' then
  467.             Address := Address + Dests[Loop];
  468.           if Phase = 'N' then
  469.             Name := Name + Dests[Loop];
  470.           if Phase = 'U' then
  471.             Unknown := Unknown + Dests[Loop];
  472.         end;
  473.       end;
  474.     end;
  475.   end;
  476.   if Phase = 'U' then
  477.     Address := Unknown;
  478.   Name := DecodeLine7Bit(TrimSpace(Name));
  479.   Address := TrimSpace(Address);
  480. end;
  481. // Count the instances of 'Received' fields in header
  482. function TMailMessage2000.GetReceivedCount: Integer;
  483. begin
  484.   Result := 0;
  485.   while SearchStringList(FHeader, 'Received:', Result) >= 0 do
  486.     Inc(Result);
  487. end;
  488. // Retrieve a 'Received' field
  489. function TMailMessage2000.GetReceived(const Index: Integer): TReceived;
  490. var
  491.   Dests: String;
  492.   Loop: Integer;
  493.   Quote: Integer;
  494.   Value: String;
  495.   Field: TReceivedField;
  496. begin
  497.   Result.From := '';
  498.   Result.By := '';
  499.   Result.Address := '';
  500.   Result.Date := 0;
  501.   Dests := Trim(Copy(FHeader[SearchStringList(FHeader, 'Received', Index)], 10, 9999))+#1;
  502.   Value := '';
  503.   Field := reNone;
  504.   Quote := 0;
  505.   for Loop := 1 to Length(Dests) do
  506.   begin
  507.     if Dests[Loop] in ['(', '['] then
  508.       Inc(Quote);
  509.     if Dests[Loop] in [')', ']'] then
  510.       Dec(Quote);
  511.     if Quote < 0 then
  512.       Quote := 0;
  513.     if (not (Dests[Loop] in ['"', '<', '>', #39, ')', ']'])) and (Quote = 0) then
  514.     begin
  515.       if (Dests[Loop] = #32) and (Field = reNone) then
  516.       begin
  517.         if LowerCase(Trim(Value)) = 'from' then
  518.           Field := reFrom;
  519.         if LowerCase(Trim(Value)) = 'by' then
  520.           Field := reBy;
  521.         if LowerCase(Trim(Value)) = 'for' then
  522.           Field := reFor;
  523.         Value := '';
  524.       end;
  525.       if Dests[Loop] in [#32, ';'] then
  526.       begin
  527.         if (Trim(Value) <> '') and (Field in [reFrom, reBy, reFor]) then
  528.         begin
  529.           case Field of
  530.             reFrom: Result.From := Trim(Value);
  531.             reBy: Result.By := Trim(Value);
  532.             reFor: Result.Address := Trim(Value);
  533.           end;
  534.           Value := '';
  535.           Field := reNone;
  536.         end;
  537.       end;
  538.       if not (Dests[Loop] in [#32, ';']) then
  539.       begin
  540.         Value := Value + Dests[Loop];
  541.       end;
  542.       if Dests[Loop] = ';' then
  543.       begin
  544.         Value := Copy(Dests, Loop+1, Length(Dests));
  545.         Result.Date := MailDateToDelphiDate(Trim(Value));
  546.         Break;
  547.       end;
  548.     end;
  549.   end;
  550. end;
  551. // Add a 'Received:' in message header
  552. procedure TMailMessage2000.AddHop(const From, By, Aplic, Address: String);
  553. var
  554.   Text: String;
  555. begin
  556.   Text := 'Received:';
  557.   if From <> '' then
  558.     Text := Text + #32'from'#32+From;
  559.   if By <> '' then
  560.     Text := Text + #32'by'#32+By;
  561.   if Aplic <> '' then
  562.     Text := Text + #32'with'#32+Aplic;
  563.   if Address <> '' then
  564.     Text := Text + #32'for'#32'<'+Address+'>';
  565.   Text := Text + ';'#32+DelphiDateToMailDate(Now);
  566.   FHeader.Insert(0, Text);
  567. end;
  568. // Get the From: name
  569. function TMailMessage2000.GetFromName: String;
  570. var
  571.   Void: String;
  572. begin
  573.   GetSenderData(_FFR, Result, Void);
  574. end;
  575. // Get the From: address
  576. function TMailMessage2000.GetFromAddress: String;
  577. var
  578.   Void: String;
  579. begin
  580.   GetSenderData(_FFR, Void, Result);
  581. end;
  582. // Get the Reply-To: name
  583. function TMailMessage2000.GetReplyToName: String;
  584. var
  585.   Void: String;
  586. begin
  587.   GetSenderData(_FRT, Result, Void);
  588. end;
  589. // Get the Reply-To: address
  590. function TMailMessage2000.GetReplyToAddress: String;
  591. var
  592.   Void: String;
  593. begin
  594.   GetSenderData(_FRT, Void, Result);
  595. end;
  596. // Get the Retrun-Receipt name
  597. function TMailMessage2000.GetReceiptName: String;
  598. var
  599.   Void: String;
  600. begin
  601.   GetSenderData(_DNT, Result, Void);
  602. end;
  603. // Get the Return-Receipt address
  604. function TMailMessage2000.GetReceiptAddress: String;
  605. var
  606.   Void: String;
  607. begin
  608.   GetSenderData(_DNT, Void, Result);
  609. end;
  610. // Set the From: name/address
  611. procedure TMailMessage2000.SetFrom(const Name, Address: String);
  612. begin
  613.   if (Name <> '') and (Address <> '') then
  614.     SetLabelValue(_FFR, '"' + EncodeLine7Bit(Name, FCharset) + '" <' + Address + '>')
  615.   else
  616.     if Address <> '' then
  617.       SetLabelValue(_FFR, '<' + Address + '>')
  618.     else
  619.       SetLabelValue(_FFR, '');
  620. end;
  621. // Set the Reply-To: name/address
  622. procedure TMailMessage2000.SetReplyTo(const Name, Address: String);
  623. begin
  624.   if (Name <> '') and (Address <> '') then
  625.     SetLabelValue(_FRT, '"' + EncodeLine7Bit(Name, FCharset) + '" <' + Address + '>')
  626.   else
  627.     if Address <> '' then
  628.       SetLabelValue(_FRT, '<' + Address + '>')
  629.     else
  630.       SetLabelValue(_FRT, '');
  631. end;
  632. // Set the Return-Receipt name/address
  633. procedure TMailMessage2000.SetReceipt(const Name, Address: String);
  634. begin
  635.   if (Name <> '') and (Address <> '') then
  636.     SetLabelValue(_DNT, '"' + EncodeLine7Bit(Name, FCharset) + '" <' + Address + '>')
  637.   else
  638.     if Address <> '' then
  639.       SetLabelValue(_DNT, '<' + Address + '>')
  640.     else
  641.       SetLabelValue(_DNT, '');
  642. end;
  643. // Get the subject
  644. function TMailMessage2000.GetSubject: String;
  645. begin
  646.   Result := DecodeLine7Bit(GetLabelValue('Subject'));
  647. end;
  648. // Set the subject
  649. procedure TMailMessage2000.SetSubject(const Subject: String);
  650. begin
  651.   SetLabelValue('Subject', EncodeLine7Bit(Subject, FCharset))
  652. end;
  653. // Get the mail priority
  654. function TMailMessage2000.GetPriority: TMailPriority;
  655. begin
  656.   Result := TMailPriority(StrToIntDef(GetToken(0, GetLabelValue(_XPRI), #32, '("', ')"'), 3)-1);
  657. end;
  658. // Set the mail priority
  659. procedure TMailMessage2000.SetPriority(const Priority: TMailPriority);
  660. begin
  661.   SetLabelValue(_XPRI, IntToStr(Ord(Priority)+1));
  662. end;
  663. // Get the date in TDateTime format
  664. function TMailMessage2000.GetDate: TDateTime;
  665. begin
  666.   Result := MailDateToDelphiDate(TrimSpace(GetLabelValue('Date')));
  667. end;
  668. // Set the date in RFC822 format
  669. procedure TMailMessage2000.SetDate(const Date: TDateTime);
  670. begin
  671.   SetLabelValue('Date', DelphiDateToMailDate(Date));
  672. end;
  673. // Get message id
  674. function TMailMessage2000.GetMessageId: String;
  675. begin
  676.   Result := GetLabelValue(_M_ID);
  677. end;
  678. // Set a unique message id (the parameter is just the host)
  679. procedure TMailMessage2000.SetMessageId(const MessageId: String);
  680. var
  681.   IDStr: String;
  682. begin
  683.   IDStr := '<'+FormatDateTime('yyyymmddhhnnss', Now)+'.'+TrimSpace(Format('%8x', [Random($FFFFFFFF)]))+'.'+TrimSpace(Format('%8x', [Random($FFFFFFFF)]))+'@'+MessageId+'>';
  684.   SetLabelValue(_M_ID, IDStr);
  685. end;
  686. // Searches for attached files and determines AttachList, TextPlain, TextHTML.
  687. procedure TMailMessage2000.FindParts;
  688.   function GetPart(Part: TMailPart): Boolean;
  689.     function GetText(Info: String): Boolean;
  690.     var
  691.       Buffer: PChar;
  692.     begin
  693.       Result := False;
  694.       if FTextPlainPart = nil then
  695.       begin
  696.         if (Info = _T_P) or (Info = _TEX) then
  697.         begin
  698.           if Part.Decode and (Part.Decoded.Size > 0) then
  699.           begin
  700.             FTextPlainPart := Part;
  701.             GetMem(Buffer, Part.FDecoded.Size+1);
  702.             StrLCopy(Buffer, Part.FDecoded.Memory, Part.FDecoded.Size);
  703.             Buffer[Part.FDecoded.Size] := #0;
  704.             FTextPlain.SetText(Buffer);
  705.             FreeMem(Buffer);
  706.             Result := True;
  707.           end;
  708.         end;
  709.       end;
  710.       if (FTextHTMLPart = nil) and (Info = _T_H) then
  711.       begin
  712.         if Part.Decode and (Part.Decoded.Size > 0) then
  713.         begin
  714.           FTextHTMLPart := Part;
  715.           GetMem(Buffer, Part.FDecoded.Size+1);
  716.           StrLCopy(Buffer, Part.FDecoded.Memory, Part.FDecoded.Size);
  717.           Buffer[Part.FDecoded.Size] := #0;
  718.           FTextHTML.SetText(Buffer);
  719.           FreeMem(Buffer);
  720.           Result := True;
  721.         end;
  722.       end;
  723.     end;
  724.   begin
  725.     Result := True;
  726.     // Check for multipart/mixed
  727.     if (FMixedPart = nil) and (Part.GetAttachInfo = _M_M) then
  728.     begin
  729.       FMixedPart := Part;
  730.       Exit;
  731.     end;
  732.     // Check for multipart/related
  733.     if (FRelatedPart = nil) and (Part.GetAttachInfo = _M_R) then
  734.     begin
  735.       FRelatedPart := Part;
  736.       Exit;
  737.     end;
  738.     // Check for multipart/alternative
  739.     if (FAlternativePart = nil) and (Part.GetAttachInfo = _M_A) then
  740.     begin
  741.       FAlternativePart := Part;
  742.       Exit;
  743.     end;
  744.     // Check for texts (when message is only one text)
  745.     if (Part = Self) and ((Copy(Part.GetAttachInfo, 1, Length(_TXT)) = _TXT) or (Part.GetAttachInfo = _TEX)) and (FSubPartList.Count = 0) then
  746.     begin
  747.       if GetText(Part.GetAttachInfo) then
  748.         Exit;
  749.     end;
  750.     // Check for texts (when message is only one text - no mime info)
  751.     if (Part = Self) and (Part.GetAttachInfo = '') and (FSubPartList.Count = 0) then
  752.     begin
  753.       if GetText(_T_P) then
  754.         Exit;
  755.     end;
  756.     // Check for texts (when message has one text plus attachs)
  757.     if (FMixedPart <> nil) and (Part.FOwnerPart = FMixedPart) and (FAlternativePart = nil) then
  758.     begin
  759.       if GetText(Part.GetAttachInfo) then
  760.         Exit;
  761.     end;
  762.     // Check for texts (when message one text with embedded)
  763.     if (FRelatedPart <> nil) and (Part.FOwnerPart = FRelatedPart) then
  764.     begin
  765.       if GetText(Part.GetAttachInfo) then
  766.         Exit;
  767.     end;
  768.     // Check for texts (when message has alternative texts)
  769.     if (FAlternativePart <> nil) and (Part.FOwnerPart = FAlternativePart) then
  770.     begin
  771.       if GetText(Part.GetAttachInfo) then
  772.         Exit;
  773.     end;
  774.     // If everything else failed, assume attachment
  775.     if Part.FSubPartList.Count = 0 then
  776.     begin
  777.       Part.FEmbedded := Part.FOwnerPart = FRelatedPart;
  778.       FAttachList.Add(Part);
  779.     end;
  780.   end;
  781.   procedure DecodeRec(MP: TMailPart);
  782.   var
  783.     Loop: Integer;
  784.   begin
  785.     if GetPart(MP) then
  786.     begin
  787.       for Loop := 0 to MP.FSubPartList.Count-1 do
  788.       begin
  789.         DecodeRec(MP.FSubPartList[Loop]);
  790.       end;
  791.     end;
  792.   end;
  793. begin
  794.   if not FNeedFindParts then
  795.     Exit;
  796.   FAttachList.Clear;
  797.   FTextPlainPart := nil;
  798.   FTextHTMLPart := nil;
  799.   FMixedPart := nil;
  800.   FRelatedPart := nil;
  801.   FAlternativePart := nil;
  802.   FTextPlain.Clear;
  803.   FTextHTML.Clear;
  804.   FNeedFindParts := False;
  805.   DecodeRec(Self);
  806. end;
  807. // Ajust parts to the Mail2000 standards
  808. procedure TMailMessage2000.Normalize(const Kind: TNormalizer = nrFirst);
  809. var
  810.   nLoop, nOcor: Integer;
  811.   SaveBody, TmpPart, TmpMixed, TmpRelated, TmpAlternative: TMailPart;
  812.   FName: String;
  813.   nTexts, nAttachs, nEmbedded: Integer;
  814.   procedure CreateMixed(Father: TMailPart);
  815.   begin
  816.     if Father = nil then
  817.     begin
  818.       SetLabelValue(_C_T, _M_M);
  819.       SetLabelParamValue(_C_T, _BDRY, '"'+GenerateBoundary+'_mixed"');
  820.       TmpMixed := Self;
  821.     end
  822.     else
  823.     begin
  824.       TmpMixed := TMailPart.Create(Self);
  825.       TmpMixed.FOwnerMessage := Self;
  826.       TmpMixed.FOwnerPart := Father;
  827.       TmpMixed.FParentBoundary := Father.GetBoundary;
  828.       TmpMixed.SetLabelValue(_C_T, _M_R);
  829.       TmpMixed.SetLabelParamValue(_C_T, _BDRY, '"'+GenerateBoundary+'_Mixed"');
  830.       Father.FSubPartList.Add(TmpMixed);
  831.     end;
  832.   end;
  833.   procedure CreateRelated(Father: TMailPart);
  834.   begin
  835.     if Father = nil then
  836.     begin
  837.       SetLabelValue(_C_T, _M_R);
  838.       SetLabelParamValue(_C_T, _BDRY, '"'+GenerateBoundary+'_related"');
  839.       TmpRelated := Self;
  840.     end
  841.     else
  842.     begin
  843.       TmpRelated := TMailPart.Create(Self);
  844.       TmpRelated.FOwnerMessage := Self;
  845.       TmpRelated.FOwnerPart := Father;
  846.       TmpRelated.FParentBoundary := Father.GetBoundary;
  847.       TmpRelated.SetLabelValue(_C_T, _M_R);
  848.       TmpRelated.SetLabelParamValue(_C_T, _BDRY, '"'+GenerateBoundary+'_related"');
  849.       Father.FSubPartList.Add(TmpRelated);
  850.     end;
  851.   end;
  852.   procedure CreateAlternative(Father: TMailPart);
  853.   begin
  854.     if Father = nil then
  855.     begin
  856.       SetLabelValue(_C_T, _M_A);
  857.       SetLabelParamValue(_C_T, _BDRY, '"'+GenerateBoundary+'_alternative"');
  858.       TmpAlternative := Self;
  859.     end
  860.     else
  861.     begin
  862.       TmpAlternative := TMailPart.Create(Self);
  863.       TmpAlternative.FOwnerMessage := Self;
  864.       TmpAlternative.FOwnerPart := Father;
  865.       TmpAlternative.FParentBoundary := Father.GetBoundary;
  866.       TmpAlternative.SetLabelValue(_C_T, _M_A);
  867.       TmpAlternative.SetLabelParamValue(_C_T, _BDRY, '"'+GenerateBoundary+'_alternative"');
  868.       Father.FSubPartList.Add(TmpAlternative);
  869.     end;
  870.   end;
  871.   procedure CreateTextPlain(Father: TMailPart);
  872.   begin
  873.     FTextPlainPart.Remove;
  874.     if Father = nil then
  875.     begin
  876.       SetLabelValue(_C_T, _T_P);
  877.       SetLabelValue(_C_D, _INLN);
  878.       FTextPlainPart.Decode;
  879.       FTextPlainPart.FDecoded.Position := 0;
  880.       FDecoded.LoadFromStream(FTextPlainPart.FDecoded);
  881.       Encode(FTextEncoding);
  882.       FTextPlainPart.Free;
  883.       FTextPlainPart := Self;
  884.     end
  885.     else
  886.     begin
  887.       FTextPlainPart.FOwnerPart := Father;
  888.       FTextPlainPart.FParentBoundary := Father.GetBoundary;
  889.       FTextPlainPart.SetLabelValue(_C_T, _T_P);
  890.       FTextPlainPart.SetLabelValue(_C_D, _INLN);
  891.       FTextPlainPart.Decode;
  892.       FTextPlainPart.Encode(FTextEncoding);
  893.       FTextPlainPart.SetLabelValue(_C_L, IntToStr(FTextPlainPart.FBody.Size));
  894.       FTextPlainPart.FSubPartList.Clear;
  895.       Father.FSubPartList.Add(FTextPlainPart);
  896.     end;
  897.   end;
  898.   procedure CreateTextHTML(Father: TMailPart);
  899.   begin
  900.     FTextHTMLPart.Remove;
  901.     if Father = nil then
  902.     begin
  903.       SetLabelValue(_C_T, _T_H);
  904.       SetLabelValue(_C_D, _INLN);
  905.       FTextHTMLPart.Decode;
  906.       FTextHTMLPart.FDecoded.Position := 0;
  907.       FDecoded.LoadFromStream(FTextHTMLPart.FDecoded);
  908.       Encode(FTextEncoding);
  909.       FTextHTMLPart.Free;
  910.       FTextHTMLPart := Self;
  911.     end
  912.     else
  913.     begin
  914.       FTextHTMLPart.FOwnerPart := Father;
  915.       FTextHTMLPart.FParentBoundary := Father.GetBoundary;
  916.       FTextHTMLPart.SetLabelValue(_C_T, _T_H);
  917.       FTextHTMLPart.SetLabelValue(_C_D, _INLN);
  918.       FTextHTMLPart.Decode;
  919.       FTextHTMLPart.Encode(FTextEncoding);
  920.       FTextHTMLPart.SetLabelValue(_C_L, IntToStr(FTextHTMLPart.FBody.Size));
  921.       FTextHTMLPart.FSubPartList.Clear;
  922.       Father.FSubPartList.Add(FTextHTMLPart);
  923.     end;
  924.   end;
  925.   procedure CreateAttachment(var Part: TMailPart; Father: TMailPart);
  926.   begin
  927.     Part.Remove;
  928.     if Part.GetLabelValue(_C_T) = '' then
  929.     begin
  930.       Part.SetLabelValue(_C_T, _A_OS);
  931.     end;
  932.     FName := Part.GetFileName;
  933.     if (FName = '') then
  934.     begin
  935.       FName := 'file_'+IntToStr(FNameCount)+GetMimeExtension(Part.GetLabelValue(_C_T));
  936.       Inc(FNameCount);
  937.     end;
  938.     Part.SetLabelValue(_XM2A, '"'+EncodeLine7Bit(FName, FCharSet)+'"');
  939.     if Part.FEmbedded then
  940.     begin
  941.       Part.SetLabelParamValue(_XM2A, _EMBD, 'yes');
  942.       case FEmbedMethod of
  943.         emContentID:
  944.           if Part.GetLabelValue(_C_ID) = '' then
  945.             Part.SetLabelValue(_C_ID, '<'+FName+'>');
  946.         emContentLocation:
  947.           Part.SetLabelValue(_C_LC, FContentLocationBase+FName);
  948.       end;
  949.       Part.SetLabelValue(_C_D, _INLN);
  950.       Part.FOwnerPart := TmpRelated;
  951.       Part.FParentBoundary := TmpRelated.GetBoundary;
  952.       TmpRelated.FSubPartList.Add(Part);
  953.     end
  954.     else
  955.     begin
  956.       Part.SetLabelParamValue(_XM2A, _EMBD, 'no');
  957.       if (Part.GetLabelParamValue(_C_T, _NAME) = '') then
  958.       begin
  959.         Part.SetLabelParamValue(_C_T, _NAME, '"'+EncodeLine7Bit(FName, FCharSet)+'"');
  960.       end;
  961.       if (Part.GetLabelParamValue(_C_D, _FLNM) = '') then
  962.       begin
  963.         Part.SetLabelParamValue(_C_D, _FLNM, '"'+EncodeLine7Bit(FName, FCharSet)+'"');
  964.       end;
  965.       if Father <> nil then
  966.       begin
  967.         Part.SetLabelValue(_C_D, _ATCH);
  968.         Part.FOwnerPart := Father;
  969.         Part.FParentBoundary := Father.GetBoundary;
  970.         Father.FSubPartList.Add(Part);
  971.       end
  972.       else
  973.       begin
  974.         // Search for "Content-"
  975.         nOcor := 0;
  976.         repeat
  977.         begin
  978.           nLoop := SearchStringList(Part.FHeader, _CONT, nOcor);
  979.           Inc(nOcor);
  980.           if nLoop >= 0 then
  981.             FHeader.Add(Part.FHeader[nLoop]);
  982.         end
  983.         until nLoop < 0;
  984.         // Search for "X-Mail2000-"
  985.         nOcor := 0;
  986.         repeat
  987.         begin
  988.           nLoop := SearchStringList(Part.FHeader, _X_M2, nOcor);
  989.           Inc(nOcor);
  990.           if nLoop >= 0 then
  991.             FHeader.Add(Part.FHeader[nLoop]);
  992.         end
  993.         until nLoop < 0;
  994.         if not Part.FIsDecoded then
  995.           Part.Decode; 
  996.         Part.FDecoded.Position := 0;
  997.         FDecoded.LoadFromStream(Part.FDecoded);
  998.         Encode(etBase64);
  999.         FAttachList.Delete(FAttachList.IndexOf(Part));
  1000.         FAttachList.Add(Self);
  1001.         Part.Free;
  1002.       end;
  1003.     end;
  1004.   end;
  1005. begin
  1006.   if (not FNeedNormalize) and (Kind = nrFirst) then
  1007.     Exit;
  1008.   FindParts;
  1009.   FNeedRebuild := True;
  1010.   FNeedNormalize := False;
  1011.   FNameCount := 0;
  1012.   nTexts := 0;
  1013.   nAttachs := 0;
  1014.   nEmbedded := 0;
  1015.   // What content has this mail?
  1016.   case Kind of
  1017.     nrAddText: Inc(nTexts);
  1018.     nrAddAttach: Inc(nAttachs);
  1019.     nrAddEmbedded: Inc(nEmbedded);
  1020.   end;
  1021.   if FTextPlainPart <> nil then
  1022.     Inc(nTexts);
  1023.   if FTextHTMLPart <> nil then
  1024.     Inc(nTexts);
  1025.   for nLoop := 0 to FAttachList.Count-1 do
  1026.     if FAttachList[nLoop].FEmbedded then
  1027.       Inc(nEmbedded)
  1028.     else
  1029.       Inc(nAttachs);
  1030.   // Save current main body
  1031.   if (FBody.Size > 0) then
  1032.   begin
  1033.     SaveBody := TMailPart.Create(Self);
  1034.     SaveBody.FBody.LoadFromStream(FBody);
  1035.     SaveBody.FOwnerMessage := Self;
  1036.     // Copy content fields from main header
  1037.     nOcor := 0;
  1038.     repeat
  1039.     begin
  1040.       nLoop := SearchStringList(FHeader, _CONT, nOcor);
  1041.       Inc(nOcor);
  1042.       if nLoop >= 0 then
  1043.         SaveBody.FHeader.Add(FHeader[nLoop]);
  1044.     end
  1045.     until nLoop < 0;
  1046.     // Classify main body
  1047.     if Self = FTextPlainPart then
  1048.       FTextPlainPart := SaveBody
  1049.     else
  1050.       if Self = FTextHTMLPart then
  1051.         FTextHTMLPart := SaveBody
  1052.       else
  1053.         if Self = FMixedPart then
  1054.           FMixedPart := SaveBody
  1055.         else
  1056.           if Self = FRelatedPart then
  1057.             FRelatedPart := SaveBody
  1058.           else
  1059.             if Self = FAlternativePart then
  1060.               FAlternativePart := SaveBody
  1061.             else
  1062.               if (FSubPartList.Count = 0) then
  1063.                 FAttachList.Add(SaveBody)
  1064.               else
  1065.                 SaveBody.Free;
  1066.   end;
  1067.   // If entire mail is an attach, remove from list.
  1068.   if FAttachList.IndexOf(Self) >= 0 then
  1069.     FAttachList.Delete(FAttachList.IndexOf(Self));
  1070.   // Create new multiparts
  1071.   SetLabelValue(_C_T, '');
  1072.   SetLabelValue(_C_TE, '');
  1073.   SetLabelValue(_C_D, '');
  1074.   SetLabelValue(_C_ID, '');
  1075.   SetLabelValue(_C_LC, '');
  1076.   SetLabelValue(_C_L, '');
  1077.   SetLabelValue(_M_V, '1.0');
  1078.   SetLabelValue(_X_M, _XMailer);
  1079.   SetLabelValue(_XM2A, '');
  1080.   TmpMixed := nil;
  1081.   TmpRelated := nil;
  1082.   TmpAlternative := nil;
  1083.   FTextFather := nil;
  1084.   // There are more than one attachment?
  1085.   if nAttachs > 1 then
  1086.   begin
  1087.     CreateMixed(nil);
  1088.     FTextFather := TmpMixed;
  1089.   end;
  1090.   // There are texts plus attachments?
  1091.   if (nAttachs > 0) and (nTexts > 0) then
  1092.   begin
  1093.     CreateMixed(nil);
  1094.     FTextFather := TmpMixed;
  1095.   end;
  1096.   // There are attachments and embedded attachments?
  1097.   if (nAttachs > 0) and (nEmbedded > 0) then
  1098.   begin
  1099.     CreateMixed(nil);
  1100.     FTextFather := TmpMixed;
  1101.   end;
  1102.   // There are embedded attachments?
  1103.   if nEmbedded > 0 then
  1104.   begin
  1105.     CreateRelated(TmpMixed);
  1106.     FTextFather := TmpRelated;
  1107.   end;
  1108.   // There are more than one text?
  1109.   if nTexts > 1 then
  1110.   begin
  1111.     CreateAlternative(FTextFather);
  1112.     FTextFather := TmpAlternative;
  1113.   end;
  1114.   // Normalize text parts
  1115.   if FTextPlainPart <> nil then
  1116.     CreateTextPlain(FTextFather);
  1117.   if FTextHTMLPart <> nil then
  1118.     CreateTextHTML(FTextFather);
  1119.   // Normalize attachments
  1120.   for nLoop := 0 to FAttachList.Count-1 do
  1121.   begin
  1122.     TmpPart := FAttachList[nLoop];
  1123.     CreateAttachment(TmpPart, TmpMixed);
  1124.   end;
  1125.   // Remove old multiparts
  1126.   if (FAlternativePart <> nil) and (FAlternativePart <> Self) then
  1127.   begin
  1128.     FAlternativePart.Remove;
  1129.     FAlternativePart.Free;
  1130.   end;
  1131.   if (FRelatedPart <> nil) and (FRelatedPart <> Self) then
  1132.   begin
  1133.     FRelatedPart.Remove;
  1134.     FRelatedPart.Free;
  1135.   end;
  1136.   if (FMixedPart <> nil) and (FMixedPart <> Self) then
  1137.   begin
  1138.     FMixedPart.Remove;
  1139.     FMixedPart.Free;
  1140.   end;
  1141.   FMixedPart := TmpMixed;
  1142.   FRelatedPart := TmpRelated;
  1143.   FAlternativePart := TmpAlternative;
  1144. end;
  1145. // Insert a text on message
  1146. procedure TMailMessage2000.PutText(Text: String; var Part: TMailPart; Content: String);
  1147. begin
  1148.   if Part = nil then
  1149.     Normalize(nrAddText)
  1150.   else
  1151.     Normalize(nrFirst);
  1152.   Text := AdjustLineBreaks(Text);
  1153.   if Part = nil then
  1154.   begin
  1155.     if FTextFather <> nil then
  1156.     begin
  1157.       Part := TMailPart.Create(Self);
  1158.       Part.FOwnerPart := FTextFather;
  1159.       Part.FOwnerMessage := Self.FOwnerMessage;
  1160.       Part.FParentBoundary := FTextFather.GetBoundary;
  1161.       // Keep texts on beginning of this section
  1162.       if LowerCase(Content) = _T_P then
  1163.       begin
  1164.         FTextFather.FSubPartList.Insert(0, Part);
  1165.       end
  1166.       else
  1167.       begin
  1168.         if LowerCase(Content) = _T_H then
  1169.         begin
  1170.           if FTextFather.FSubPartList.Items[0].GetAttachInfo = _T_P then
  1171.           begin
  1172.             FTextFather.FSubPartList.Insert(1, Part);
  1173.           end
  1174.           else
  1175.           begin
  1176.             FTextFather.FSubPartList.Insert(0, Part);
  1177.           end;
  1178.         end
  1179.         else
  1180.         begin
  1181.           FTextFather.FSubPartList.Add(Part);
  1182.         end;
  1183.       end;
  1184.     end
  1185.     else
  1186.     begin
  1187.       Part := Self;
  1188.     end;
  1189.   end;
  1190.   Part.Decoded.Clear;
  1191.   Part.Decoded.Write(Text[1], Length(Text));
  1192.   Part.Encode(FTextEncoding);
  1193.   Part.SetLabelValue(_C_T, Content);
  1194.   Part.SetLabelParamValue(_C_T, _CSET, '"'+FCharset+'"');
  1195.   Part.SetLabelValue(_C_D, _INLN);
  1196.   Part.SetLabelValue(_C_L, IntToStr(Part.FBody.Size));
  1197.   FNeedRebuild := True;
  1198. end;
  1199. // Remove a text from message
  1200. procedure TMailMessage2000.RemoveText(var Part: TMailPart);
  1201. begin
  1202.   Normalize(nrFirst);
  1203.   if Part <> nil then
  1204.   begin
  1205.     if Part <> Self then
  1206.     begin
  1207.       Part.Remove;
  1208.       Part.Free;
  1209.     end
  1210.     else
  1211.     begin
  1212.       FBody.Clear;
  1213.       FDecoded.Clear;
  1214.       SetLabelValue(_C_T, '');
  1215.       SetLabelValue(_C_TE, '');
  1216.       SetLabelValue(_C_D, '');
  1217.       SetLabelValue(_C_L, '');
  1218.       SetLabelValue(_XM2A, '');
  1219.     end;
  1220.   end;
  1221.   Part := nil;
  1222.   Normalize(nrForce);
  1223.   FNeedRebuild := True;
  1224. end;
  1225. // Replace or create a mailpart for text/plain
  1226. procedure TMailMessage2000.SetTextPlain(const Text: String);
  1227. begin
  1228.   PutText(Text, FTextPlainPart, _T_P);
  1229.   FTextPlain.Text := Text;
  1230. end;
  1231. // Replace or create a mailpart for text/html
  1232. procedure TMailMessage2000.SetTextHTML(const Text: String);
  1233. begin
  1234.   PutText(Text, FTextHTMLPart, _T_H);
  1235.   FTextHTML.Text := Text;
  1236. end;
  1237. // Remove text/plain mailpart
  1238. procedure TMailMessage2000.RemoveTextPlain;
  1239. begin
  1240.   if FTextPlainPart <> nil then
  1241.   begin
  1242.     RemoveText(FTextPlainPart);
  1243.     FTextPlain.Clear;
  1244.   end;
  1245. end;
  1246. // Remove text/html mailpart
  1247. procedure TMailMessage2000.RemoveTextHTML;
  1248. begin
  1249.   if FTextHTMLPart <> nil then
  1250.   begin
  1251.     RemoveText(FTextHTMLPart);
  1252.     FTextHTML.Clear;
  1253.   end;
  1254. end;
  1255. // Create a mailpart and encode the file
  1256. procedure TMailMessage2000.AttachFile(const FileName: String; const ContentType: String = ''; const IsEmbedded: Boolean = False);
  1257. var
  1258.   MemFile: TMemoryStream;
  1259. begin
  1260.   MemFile := TMemoryStream.Create;
  1261.   MemFile.LoadFromFile(FileName);
  1262.   AttachStream(MemFile, FileName, ContentType, IsEmbedded);
  1263.   MemFile.Free;
  1264. end;
  1265. // Create a mailpart and encode the string
  1266. procedure TMailMessage2000.AttachString(const Text, FileName: String; const ContentType: String = ''; const IsEmbedded: Boolean = False);
  1267. var
  1268.   MemFile: TMemoryStream;
  1269. begin
  1270.   MemFile := TMemoryStream.Create;
  1271.   MemFile.WriteBuffer(Text[1], Length(Text));
  1272.   AttachStream(MemFile, FileName, ContentType, IsEmbedded);
  1273.   MemFile.Free;
  1274. end;
  1275. // Create a mailpart and encode the stream
  1276. procedure TMailMessage2000.AttachStream(const AStream: TStream; const FileName: String; const ContentType: String = ''; const IsEmbedded: Boolean = False);
  1277. var
  1278.   Part, Father: TMailPart;
  1279. begin
  1280.   if IsEmbedded then
  1281.   begin
  1282.     Normalize(nrAddEmbedded);
  1283.     Father := FRelatedPart;
  1284.   end
  1285.   else
  1286.   begin
  1287.     Normalize(nrAddAttach);
  1288.     Father := FMixedPart;
  1289.   end;
  1290.   if Father <> nil then
  1291.   begin
  1292.     Part := TMailPart.Create(Self);
  1293.     Part.FOwnerMessage := Self;
  1294.     Part.FOwnerPart := Father;
  1295.     Part.FParentBoundary := Father.GetBoundary;
  1296.     Father.FSubPartList.Add(Part);
  1297.   end
  1298.   else
  1299.   begin
  1300.     Part := Self;
  1301.   end;
  1302.   AStream.Position := 0;
  1303.   Part.Decoded.LoadFromStream(AStream);
  1304.   Part.Decoded.Position := 0;
  1305.   Part.Encode(FAttachEncoding);
  1306.   if ContentType = '' then
  1307.     Part.SetLabelValue(_C_T, GetMimeType(ExtractFileName(FileName)))
  1308.   else
  1309.     Part.SetLabelValue(_C_T, ContentType);
  1310.   Part.SetLabelValue(_XM2A, '"'+EncodeLine7Bit(ExtractFileName(FileName), FCharSet)+'"');
  1311.   Part.SetLabelValue(_C_L, IntToStr(Part.FBody.Size));
  1312.   Part.FEmbedded := IsEmbedded;
  1313.   if IsEmbedded then
  1314.   begin
  1315.     Part.SetLabelValue(_C_D, _INLN);
  1316.     Part.SetLabelParamValue(_XM2A, _EMBD, 'yes');
  1317.     case FEmbedMethod of
  1318.       emContentID:
  1319.         Part.SetLabelValue(_C_ID, '<'+ ExtractFileName(FileName) +'>');
  1320.       emContentLocation:
  1321.         Part.SetLabelValue(_C_LC, FContentLocationBase + ExtractFileName(FileName));
  1322.     end;
  1323.   end
  1324.   else
  1325.   begin
  1326.     Part.SetLabelValue(_C_D, _ATCH);
  1327.     Part.SetLabelParamValue(_C_T, _NAME, '"'+EncodeLine7Bit(ExtractFileName(FileName), FCharSet)+'"');
  1328.     Part.SetLabelParamValue(_C_D, _FLNM, '"'+EncodeLine7Bit(ExtractFileName(FileName), FCharSet)+'"');
  1329.     Part.SetLabelParamValue(_XM2A, _EMBD, 'no');
  1330.   end;
  1331.   FAttachList.Add(Part);
  1332.   FNeedRebuild := True;
  1333. end;
  1334. // Remove attached file from message
  1335. procedure TMailMessage2000.DetachFile(const FileName: String);
  1336. var
  1337.   nLoop: Integer;
  1338. begin
  1339.   Normalize(nrFirst);
  1340.   for nLoop := 0 to FAttachList.Count-1 do
  1341.   begin
  1342.     if LowerCase(FAttachList[nLoop].FileName) = LowerCase(ExtractFileName(FileName)) then
  1343.     begin
  1344.       if FAttachList[nLoop] <> Self then
  1345.       begin
  1346.         FAttachList[nLoop].Remove;
  1347.         FAttachList[nLoop].Free;
  1348.       end
  1349.       else
  1350.       begin
  1351.         SetLabelValue(_C_T, '');
  1352.         SetLabelValue(_C_TE, '');
  1353.         SetLabelValue(_C_D, '');
  1354.         SetLabelValue(_C_L, '');
  1355.         SetLabelValue(_C_ID, '');
  1356.         SetLabelValue(_C_LC, '');
  1357.         SetLabelValue(_XM2A, '');
  1358.         FBody.Clear;
  1359.         FDecoded.Clear;
  1360.       end;
  1361.       FAttachList.Delete(nLoop);
  1362.       FNeedRebuild := True;
  1363.       Break;
  1364.     end;
  1365.   end;
  1366.   if not FNeedRebuild then
  1367.     raise Exception.CreateFmt(_E_ATFN, [Self.Name, FileName])
  1368.   else
  1369.     Normalize(nrForce);
  1370. end;
  1371. // Remove attached file from message by AttachList index
  1372. procedure TMailMessage2000.DetachFileIndex(const Index: Integer);
  1373. begin
  1374.   Normalize(nrFirst);
  1375.   if (Index < FAttachList.Count) and (Index >= 0) then
  1376.   begin
  1377.     if FAttachList[Index] <> Self then
  1378.     begin
  1379.       FAttachList[Index].Remove;
  1380.       FAttachList[Index].Free;
  1381.     end
  1382.     else
  1383.     begin
  1384.       SetLabelValue(_C_T, '');
  1385.       SetLabelValue(_C_TE, '');
  1386.       SetLabelValue(_C_D, '');
  1387.       SetLabelValue(_C_L, '');
  1388.       SetLabelValue(_C_ID, '');
  1389.       SetLabelValue(_C_LC, '');
  1390.       SetLabelValue(_XM2A, '');
  1391.       FBody.Clear;
  1392.       FDecoded.Clear;
  1393.     end;
  1394.     FAttachList.Delete(Index);
  1395.     FNeedRebuild := True;
  1396.     Normalize(nrForce);
  1397.   end
  1398.   else
  1399.     raise Exception.CreateFmt(_E_ATIN, [Self.Name]);
  1400. end;
  1401. // Find the part containing the specified attachment
  1402. function TMailMessage2000.GetAttach(const FileName: String): TMailPart;
  1403. var
  1404.   nLoop: Integer;
  1405. begin
  1406.   Normalize(nrFirst);
  1407.   Result := nil;
  1408.   for nLoop := 0 to FAttachList.Count-1 do
  1409.   begin
  1410.     if LowerCase(FAttachList[nLoop].FileName) = LowerCase(FileName) then
  1411.     begin
  1412.       Result := FAttachList[nLoop];
  1413.       Break;
  1414.     end;
  1415.   end;
  1416. end;
  1417. // Rebuild body text according to the mailparts
  1418. procedure TMailMessage2000.RebuildBody;
  1419. var
  1420.   sLine: String;
  1421.   procedure RebuildBodyRec(MP: TMailPart);
  1422.   var
  1423.     Loop: Integer;
  1424.     Line: Integer;
  1425.     Data: String;
  1426.     nPos: Integer;
  1427.   begin
  1428.     for Loop := 0 to MP.SubPartList.Count-1 do
  1429.     begin
  1430.       sLine := #13#10;
  1431.       FBody.Write(sLine[1], Length(sLine));
  1432.       sLine :=  '--'+MP.SubPartList[Loop].FParentBoundary+#13#10;
  1433.       FBody.Write(sLine[1], Length(sLine));
  1434.       for Line := 0 to MP.SubPartList[Loop].FHeader.Count-1 do
  1435.       begin
  1436.         if Length(MP.SubPartList[Loop].FHeader[Line]) > 0 then
  1437.         begin
  1438.           sLine := MP.SubPartList[Loop].FHeader[Line]+#13#10;
  1439.           FBody.Write(sLine[1], Length(sLine));
  1440.         end;
  1441.       end;
  1442.       sLine := #13#10;
  1443.       FBody.Write(sLine[1], Length(sLine));
  1444.       if MP.SubPartList[Loop].SubPartList.Count > 0 then
  1445.       begin
  1446.         RebuildBodyRec(MP.SubPartList[Loop]);
  1447.       end
  1448.       else
  1449.       begin
  1450.         SetLength(Data, MP.SubPartList[Loop].FBody.Size);
  1451.         if MP.SubPartList[Loop].FBody.Size > 0 then
  1452.         begin
  1453.           MP.SubPartList[Loop].FBody.Position := 0;
  1454.           MP.SubPartList[Loop].FBody.ReadBuffer(Data[1], MP.SubPartList[Loop].FBody.Size);
  1455.           nPos := 1;
  1456.           while nPos >= 0 do
  1457.           begin
  1458.             DataLine(Data, sLine, nPos);
  1459.             sLine := sLine;
  1460.             FBody.Write(sLine[1], Length(sLine));
  1461.           end;
  1462.         end;
  1463.       end;
  1464.     end;
  1465.     if MP.SubPartList.Count > 0 then
  1466.     begin
  1467.       sLine := #13#10;
  1468.       FBody.Write(sLine[1], Length(sLine));
  1469.       sLine := '--'+MP.SubPartList[0].FParentBoundary+'--'#13#10;
  1470.       FBody.Write(sLine[1], Length(sLine));
  1471.     end;
  1472.   end;
  1473. begin
  1474.   if not FNeedRebuild then
  1475.     Exit;
  1476.   if SubPartList.Count > 0 then
  1477.   begin
  1478.     FBody.Clear;
  1479.     sLine := _MIME_Msg;
  1480.     FBody.Write(sLine[1], Length(sLine));
  1481.     RebuildBodyRec(Self);
  1482.   end;
  1483.   SetLabelValue(_C_L, IntToStr(FBody.Size));
  1484.   FNeedRebuild := False;
  1485. end;
  1486. // Empty data stored in the object
  1487. procedure TMailMessage2000.Reset;
  1488. var
  1489.   Loop: Integer;
  1490. begin
  1491.   for Loop := 0 to FSubPartList.Count-1 do
  1492.     FSubPartList.Items[Loop].Destroy;
  1493.   FHeader.Clear;
  1494.   FBody.Clear;
  1495.   FDecoded.Clear;
  1496.   FSubPartList.Clear;
  1497.   FAttachList.Clear;
  1498.   FTextPlain.Clear;
  1499.   FTextHTML.Clear;
  1500.   FTextPlainPart := nil;
  1501.   FTextHTMLPart := nil;
  1502.   FMixedPart := nil;
  1503.   FRelatedPart := nil;
  1504.   FAlternativePart := nil;
  1505.   FNeedRebuild := False;
  1506.   FNeedNormalize := False;
  1507.   FNeedFindParts := False;
  1508.   FNameCount := 0;
  1509. end;
  1510. { TSocketTalk =================================================================== }
  1511. // Initialize TSocketTalk
  1512. constructor TSocketTalk.Create(AOwner: TComponent);
  1513. begin
  1514.   inherited Create(AOwner);
  1515.   FClientSocket := TClientSocket.Create(Self);
  1516.   FClientSocket.ClientType := ctNonBlocking;
  1517.   FClientSocket.OnRead := SocketRead;
  1518.   FClientSocket.OnDisconnect := SocketDisconnect;
  1519.   FClientSocket.Socket.OnErrorEvent := SocketError;
  1520.   FTimer := TTimer.Create(Self);
  1521.   FTimer.Enabled := False;
  1522.   FTimer.OnTimer := Timer;
  1523.   FTimeOut := 60;
  1524.   FLastResponse := '';
  1525.   FExpectedEnd := '';
  1526.   FDataSize := 0;
  1527.   FPacketSize := 0;
  1528.   FTalkError := teNoError;
  1529. end;
  1530. // Finalize TSocketTalk
  1531. destructor TSocketTalk.Destroy;
  1532. begin
  1533.   FClientSocket.Free;
  1534.   FTimer.Free;
  1535.   inherited Destroy;
  1536. end;
  1537. // Occurs when data is comming from the socket
  1538. procedure TSocketTalk.SocketRead(Sender: TObject; Socket: TCustomWinSocket);
  1539. var
  1540.   Buffer: String;
  1541.   BufLen: Integer;
  1542. begin
  1543.   SetLength(Buffer, Socket.ReceiveLength);
  1544.   BufLen := Socket.ReceiveBuf(Buffer[1], Length(Buffer));
  1545.   FLastResponse := FLastResponse + Copy(Buffer, 1, BufLen);
  1546.   FTalkError := teNoError;
  1547.   FTimer.Enabled := False;
  1548.   if Assigned(FOnReceiveData) then
  1549.   begin
  1550.     FOnReceiveData(Self, FSessionState, Buffer, FServerResult);
  1551.   end;
  1552.   if (FDataSize > 0) and Assigned(FOnProgress) then
  1553.   begin
  1554.     FOnProgress(Self.Owner, FDataSize, Length(FLastResponse));
  1555.   end;
  1556.   if (FExpectedEnd = '') or (Copy(FLastResponse, Length(FLastResponse)-Length(FExpectedEnd)+1, Length(FExpectedEnd)) = FExpectedEnd) then
  1557.   begin
  1558.     FTalkError := teNoError;
  1559.     FDataSize := 0;
  1560.     FExpectedEnd := '';
  1561.     FWaitingServer := False;
  1562.     if Assigned(FOnEndOfData) then
  1563.     begin
  1564.       FOnEndOfData(Self, FSessionState, FLastResponse, FServerResult);
  1565.     end;
  1566.     FSessionState := stNone;
  1567.   end
  1568.   else
  1569.   begin
  1570.     FTimer.Enabled := True;
  1571.   end;
  1572. end;
  1573. // Occurs when socket is disconnected
  1574. procedure TSocketTalk.SocketDisconnect(Sender: TObject; Socket: TCustomWinSocket);
  1575. begin
  1576.   if Assigned(FOnDisconnect) then
  1577.     FOnDisconnect(Self);
  1578.   FTimer.Enabled := False;
  1579.   FWaitingServer := False;
  1580.   FSessionState := stNone;
  1581.   FExpectedEnd := '';
  1582.   FDataSize := 0;
  1583.   FPacketSize := 0;
  1584. end;
  1585. // Occurs on socket error
  1586. procedure TSocketTalk.SocketError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
  1587. begin
  1588.   FTimer.Enabled := False;
  1589.   FTalkError := TTalkError(Ord(ErrorEvent));
  1590.   FDataSize := 0;
  1591.   FExpectedEnd := '';
  1592.   FWaitingServer := False;
  1593.   FServerResult := False;
  1594.   if Assigned(FOnSocketTalkError) then
  1595.   begin
  1596.     FOnSocketTalkError(Self, FSessionState, FTalkError);
  1597.   end;
  1598.   FSessionState := stNone;
  1599.   ErrorCode := 0;
  1600. end;
  1601. // Occurs on timeout
  1602. procedure TSocketTalk.Timer(Sender: TObject);
  1603. begin
  1604.   FTimer.Enabled := False;
  1605.   FTalkError := teTimeout;
  1606.   FDataSize := 0;
  1607.   FExpectedEnd := '';
  1608.   FWaitingServer := False;
  1609.   FServerResult := False;
  1610.   if Assigned(FOnSocketTalkError) then
  1611.   begin
  1612.     FOnSocketTalkError(Self, FSessionState, FTalkError);
  1613.   end;
  1614.   FSessionState := stNone;
  1615. end;
  1616. // Cancel the waiting for server response
  1617. procedure TSocketTalk.Cancel;
  1618. begin
  1619.   FTimer.Enabled := False;
  1620.   FTalkError := teNoError;
  1621.   FSessionState := stNone;
  1622.   FExpectedEnd := '';
  1623.   FDataSize := 0;
  1624.   FWaitingServer := False;
  1625.   FServerResult := False;
  1626. end;
  1627. // Inform that the data comming belongs
  1628. procedure TSocketTalk.ForceState(SessionState: TSessionState);
  1629. begin
  1630.   FExpectedEnd := '';
  1631.   FLastResponse := '';
  1632.   FTimer.Interval := FTimeOut * 1000;
  1633.   FTimer.Enabled := True;
  1634.   FDataSize := 0;
  1635.   FTalkError := teNoError;
  1636.   FSessionState := SessionState;
  1637.   FWaitingServer := True;
  1638.   FServerResult := False;
  1639. end;
  1640. // Send a command to server
  1641. procedure TSocketTalk.Talk(Buffer, EndStr: String; SessionState: TSessionState);
  1642. var
  1643.   nPos: Integer;
  1644.   nLen: Integer;
  1645. begin
  1646.   FExpectedEnd := EndStr;
  1647.   FSessionState := SessionState;
  1648.   FLastResponse := '';
  1649.   FTimer.Interval := FTimeOut * 1000;
  1650.   FTalkError := teNoError;
  1651.   FWaitingServer := True;
  1652.   FServerResult := False;
  1653.   nPos := 1;
  1654.   if (FPacketSize > 0) and (Length(Buffer) > FPacketSize) then
  1655.   begin
  1656.     if Assigned(OnProgress) then
  1657.       OnProgress(Self.Owner, Length(Buffer), 0);
  1658.     while nPos <= Length(Buffer) do
  1659.     begin
  1660.       Application.ProcessMessages;
  1661.       if (nPos+FPacketSize-1) > Length(Buffer) then
  1662.         nLen := Length(Buffer)-nPos+1
  1663.       else
  1664.         nLen := FPacketSize;
  1665.       FTimer.Enabled := True;
  1666.       while (FClientSocket.Socket.SendBuf(Buffer[nPos], nLen) = -1) do
  1667.         Sleep(10);
  1668.       FTimer.Enabled := False;
  1669.       nPos := nPos + nLen;
  1670.       if Assigned(OnProgress) then
  1671.         OnProgress(Self.Owner, Length(Buffer), nPos-1);
  1672.     end;
  1673.     if Assigned(OnProgress) then
  1674.       OnProgress(Self.Owner, Length(Buffer), Length(Buffer));
  1675.   end
  1676.   else
  1677.   begin
  1678.     while (FClientSocket.Socket.SendBuf(Buffer[1], Length(Buffer)) = -1 )
  1679.        do Sleep (10);
  1680.   end;
  1681.   FPacketSize := 0;
  1682. end;
  1683. // Wait for server response
  1684. // by Rene de Jong (rmdejong@ism.nl)
  1685. procedure TSocketTalk.WaitServer;
  1686. begin
  1687.   FTimer.Interval := FTimeOut * 1000;
  1688.   while FWaitingServer and (not FServerResult) do
  1689.   begin
  1690.     FTimer.Enabled := True;
  1691.     Application.ProcessMessages;
  1692.   end;
  1693.   FTimer.Enabled := False;
  1694. end;
  1695. { TPOP2000 ====================================================================== }
  1696. // Initialize TPOP2000
  1697. constructor TPOP2000.Create;
  1698. begin
  1699.   FSocketTalk := TSocketTalk.Create(Self);
  1700.   FSocketTalk.OnEndOfData := EndOfData;
  1701.   FSocketTalk.OnSocketTalkError := SocketTalkError;
  1702.   FSocketTalk.OnReceiveData := ReceiveData;
  1703.   FSocketTalk.OnDisconnect := SocketDisconnect;
  1704.   FHost := '';
  1705.   FPort := 110;
  1706.   FUserName := '';
  1707.   FPassword := '';
  1708.   FSessionMessageCount := -1;
  1709.   FSessionConnected := False;
  1710.   FSessionLogged := False;
  1711.   FMailMessage := nil;
  1712.   FDeleteOnRetrieve := False;
  1713.   SetLength(FSessionMessageSize, 0);
  1714.   inherited Create(AOwner);
  1715. end;
  1716. // Finalize TPOP2000
  1717. destructor TPOP2000.Destroy;
  1718. begin
  1719.   FSocketTalk.Free;
  1720.   SetLength(FSessionMessageSize, 0);
  1721.   inherited Destroy;
  1722. end;
  1723. // Set timeout
  1724. procedure TPOP2000.SetTimeOut(Value: Integer);
  1725. begin
  1726.   FSocketTalk.TimeOut := Value;
  1727. end;
  1728. // Get timeout
  1729. function TPOP2000.GetTimeOut: Integer;
  1730. begin
  1731.   Result := FSocketTalk.TimeOut;
  1732. end;
  1733. // Set OnProgress event
  1734. procedure TPOP2000.SetProgress(Value: TProgressEvent);
  1735. begin
  1736.   FSocketTalk.OnProgress := Value;
  1737. end;
  1738. // Get OnProgress event
  1739. function TPOP2000.GetProgress: TProgressEvent;
  1740. begin
  1741.   Result := FSocketTalk.OnProgress;
  1742. end;
  1743. // Get LastResponse
  1744. function TPOP2000.GetLastResponse: String;
  1745. begin
  1746.   Result := FSocketTalk.LastResponse;
  1747. end;
  1748. // When data from server ends
  1749. procedure TPOP2000.EndOfData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
  1750. begin
  1751.   case SessionState of
  1752.     stConnect, stUser, stPass, stStat, stList, stRetr, stQuit, stDele, stUIDL:
  1753.     if Copy(Data, 1, 3) = '+OK' then
  1754.       ServerResult := True;
  1755.   end;
  1756. end;
  1757. // On socket error
  1758. procedure TPOP2000.SocketTalkError(Sender: TObject; SessionState: TSessionState; TalkError: TTalkError);
  1759. begin
  1760.   FSocketTalk.Cancel;
  1761. end;
  1762. // On data received
  1763. procedure TPOP2000.ReceiveData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
  1764. begin
  1765.   if (Copy(Data, 1, 4) = '-ERR') and (Copy(Data, Length(Data)-1, 2) = #13#10) then
  1766.   begin
  1767.     ServerResult := False;
  1768.     FSocketTalk.Cancel;
  1769.   end;
  1770. end;
  1771. // On socket disconnected
  1772. procedure TPOP2000.SocketDisconnect(Sender: TObject);
  1773. begin
  1774.   FSessionMessageCount := -1;
  1775.   FSessionConnected := False;
  1776.   FSessionLogged := False;
  1777.   SetLength(FSessionMessageSize, 0);
  1778. end;
  1779. // Connect socket
  1780. function TPOP2000.Connect: Boolean;
  1781. begin
  1782.   if FSessionConnected or FSocketTalk.ClientSocket.Active then
  1783.   begin
  1784.     Result := False;
  1785.     Exit;
  1786.   end;
  1787.   if Length(FHost) = 0 then
  1788.   begin
  1789.     Result := False;
  1790.     Exit;
  1791.   end;
  1792.   if not IsIPAddress(FHost) then
  1793.   begin
  1794.     FSocketTalk.ClientSocket.Host := FHost;
  1795.     FSocketTalk.ClientSocket.Address := '';
  1796.   end
  1797.   else
  1798.   begin
  1799.     FSocketTalk.ClientSocket.Host := '';
  1800.     FSocketTalk.ClientSocket.Address := FHost;
  1801.   end;
  1802.   FSocketTalk.ClientSocket.Port := FPort;
  1803.   FSocketTalk.ForceState(stConnect);
  1804.   FSocketTalk.ClientSocket.Open;
  1805.   FSocketTalk.WaitServer;
  1806.   FSessionConnected := FSocketTalk.ServerResult;
  1807.   Result := FSocketTalk.ServerResult;
  1808. end;
  1809. // POP3 Logon
  1810. function TPOP2000.Login: Boolean;
  1811. var
  1812.   MsgList: TStringList;
  1813.   Loop: Integer;
  1814.   cStat: String;
  1815. begin
  1816.   Result := False;
  1817.   if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
  1818.   begin
  1819.     Exit;
  1820.   end;
  1821.   FSocketTalk.Talk('USER'#32+FUserName+#13#10, #13#10, stUser);
  1822.   FSocketTalk.WaitServer;
  1823.   if FSocketTalk.ServerResult then
  1824.   begin
  1825.     FSocketTalk.Talk('PASS'#32+FPassword+#13#10, #13#10, stPass);
  1826.     FSocketTalk.WaitServer;
  1827.     if FSocketTalk.ServerResult then
  1828.     begin
  1829.       FSessionLogged := True;
  1830.       FSocketTalk.Talk('LIST'#13#10, _DATAEND1, stList);
  1831.       FSocketTalk.WaitServer;
  1832.       if FSocketTalk.ServerResult then
  1833.       begin
  1834.         MsgList := TStringList.Create;
  1835.         MsgList.Text := FSocketTalk.LastResponse;
  1836.         if MsgList.Count > 2 then
  1837.         begin
  1838.           cStat := TrimSpace(MsgList[MsgList.Count-2]);
  1839.           FSessionMessageCount := StrToIntDef(Copy(cStat, 1, Pos(#32, cStat)-1), -1);
  1840.           if FSessionMessageCount > 0 then
  1841.           begin
  1842.             for Loop := 1 to MsgList.Count-2 do
  1843.             begin
  1844.               cStat := TrimSpace(MsgList[Loop]);
  1845.               cStat := Copy(cStat, 1, Pos(#32, cStat)-1);
  1846.               SetLength(FSessionMessageSize, StrToInt(cStat)+1);
  1847.               if StrToIntDef(cStat, 0) > 0 then
  1848.                 FSessionMessageSize[StrToInt(cStat)] := StrToIntDef(Copy(MsgList[Loop], Pos(#32, MsgList[Loop])+1, 99), 0);
  1849.             end;
  1850.             FSessionMessageSize[0] := 0;
  1851.           end;
  1852.         end
  1853.         else
  1854.         begin
  1855.           FSessionMessageCount := 0;
  1856.           SetLength(FSessionMessageSize, 0);
  1857.         end;
  1858.         MsgList.Free;
  1859.       end;
  1860.     end;
  1861.   end;
  1862.   Result := FSessionLogged;
  1863. end;
  1864. // POP3 Quit
  1865. function TPOP2000.Quit: Boolean;
  1866. begin
  1867.   Result := False;
  1868.   if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
  1869.   begin
  1870.     Exit;
  1871.   end;
  1872.   FSocketTalk.Talk('QUIT'#13#10, #13#10, stQuit);
  1873.   FSocketTalk.WaitServer;
  1874.   if FSocketTalk.ServerResult then
  1875.   begin
  1876.     FSocketTalk.ClientSocket.Close;
  1877.     FSessionConnected := False;
  1878.     FSessionLogged := False;
  1879.     FSessionMessageCount := -1;
  1880.     Result := True;
  1881.   end;
  1882. end;
  1883. // Force disconnection
  1884. procedure TPOP2000.Abort;
  1885. begin
  1886.   FSocketTalk.ClientSocket.Close;
  1887.   FSessionConnected := False;
  1888.   FSessionLogged := False;
  1889.   FSessionMessageCount := -1;
  1890. end;
  1891. // Retrieve message#
  1892. function TPOP2000.RetrieveMessage(Number: Integer): Boolean;
  1893. var
  1894.   MailTxt: TStringList;
  1895. begin
  1896.   Result := False;
  1897.   FLastMessage := '';
  1898.   if (not FSessionConnected) or (not FSessionLogged) or (not FSocketTalk.ClientSocket.Active) then
  1899.   begin
  1900.     Exit;
  1901.   end;
  1902.   FSocketTalk.DataSize := FSessionMessageSize[Number-1];
  1903.   FSocketTalk.Talk('RETR'#32+IntToStr(Number)+#13#10, _DATAEND1, stRetr);
  1904.   FSocketTalk.WaitServer;
  1905.   if FSocketTalk.ServerResult then
  1906.   begin
  1907.     MailTxt := TStringList.Create;
  1908.     MailTxt.Text := FSocketTalk.LastResponse;
  1909.     MailTxt.Delete(MailTxt.Count-1);
  1910.     MailTxt.Delete(0);
  1911.     FLastMessage := MailTxt.Text;
  1912.     MailTxt.Free;
  1913.     if Assigned(FMailMessage) then
  1914.     begin
  1915.       FMailMessage.Reset;
  1916.       FMailMessage.Fill(PChar(FLastMessage), True);
  1917.     end;
  1918.     Result := True;
  1919.     if FDeleteOnRetrieve then
  1920.       DeleteMessage(Number);
  1921.   end;
  1922. end;
  1923. // Retrieve message# (only header)
  1924. function TPOP2000.RetrieveHeader(Number: Integer; Lines: Integer = 0): Boolean;
  1925. var
  1926.   MailTxt: TStringList;
  1927. begin
  1928.   Result := False;
  1929.   FLastMessage := '';
  1930.   if (not FSessionConnected) or (not FSessionLogged) or (not FSocketTalk.ClientSocket.Active) then
  1931.   begin
  1932.     Exit;
  1933.   end;
  1934.   FSocketTalk.DataSize := FSessionMessageSize[Number-1];
  1935.   FSocketTalk.Talk('TOP'#32+IntToStr(Number)+#32+IntToStr(Lines)+#13#10, _DATAEND1, stRetr);
  1936.   FSocketTalk.WaitServer;
  1937.   if FSocketTalk.ServerResult then
  1938.   begin
  1939.     MailTxt := TStringList.Create;
  1940.     MailTxt.Text := FSocketTalk.LastResponse;
  1941.     MailTxt.Delete(MailTxt.Count-1);
  1942.     MailTxt.Delete(0);
  1943.     FLastMessage := MailTxt.Text;
  1944.     MailTxt.Free;
  1945.     if Assigned(FMailMessage) then
  1946.     begin
  1947.       FMailMessage.Reset;
  1948.       FMailMessage.FHeader.Text := PChar(FLastMessage);
  1949.     end;
  1950.     Result := True;
  1951.   end;
  1952. end;
  1953. // Delete message#
  1954. function TPOP2000.DeleteMessage(Number: Integer): Boolean;
  1955. begin
  1956.   Result := False;
  1957.   if (not FSessionConnected) or (not FSessionLogged) or (not FSocketTalk.ClientSocket.Active) then
  1958.   begin
  1959.     Exit;
  1960.   end;
  1961.   FSocketTalk.Talk('DELE'#32+IntToStr(Number)+#13#10, #13#10, stDele);
  1962.   FSocketTalk.WaitServer;
  1963.   if FSocketTalk.ServerResult then
  1964.   begin
  1965.     Result := True;
  1966.   end;
  1967. end;
  1968. // Get UIDL from message#
  1969. function TPOP2000.GetUIDL(Number: Integer): String;
  1970. var
  1971.   MsgNum: String;
  1972. begin
  1973.   Result := '';
  1974.   MsgNum := IntToStr(Number);
  1975.   if (not FSessionConnected) or (not FSessionLogged) or (not FSocketTalk.ClientSocket.Active) then
  1976.   begin
  1977.     Exit;
  1978.   end;
  1979.   FSocketTalk.Talk('UIDL'#32+MsgNum+#13#10, #13#10, stUIDL);
  1980.   FSocketTalk.WaitServer;
  1981.   if FSocketTalk.ServerResult then
  1982.   begin
  1983.     Result := FSocketTalk.LastResponse;
  1984.     Result := Trim(Copy(Result, Pos(MsgNum+#32, Result)+Length(MsgNum)+1, Length(Result)));
  1985.   end;
  1986. end;
  1987. { TSMTP2000 ====================================================================== }
  1988. // Initialize TSMTP2000
  1989. constructor TSMTP2000.Create;
  1990. begin
  1991.   FSocketTalk := TSocketTalk.Create(Self);
  1992.   FSocketTalk.OnEndOfData := EndOfData;
  1993.   FSocketTalk.OnSocketTalkError := SocketTalkError;
  1994.   FSocketTalk.OnReceiveData := ReceiveData;
  1995.   FSocketTalk.OnDisconnect := SocketDisconnect;
  1996.   FHost := '';
  1997.   FPort := 25;
  1998.   FSessionConnected := False;
  1999.   FPacketSize := 102400;
  2000.   FUserName := '';
  2001.   FPassword := '';
  2002.   FHandshaking := hsAuto;
  2003.   inherited Create(AOwner);
  2004. end;
  2005. // Finalize TSMTP2000
  2006. destructor TSMTP2000.Destroy;
  2007. begin
  2008.   FSocketTalk.Free;
  2009.   inherited Destroy;
  2010. end;
  2011. // Set timeout
  2012. procedure TSMTP2000.SetTimeOut(Value: Integer);
  2013. begin
  2014.   FSocketTalk.TimeOut := Value;
  2015. end;
  2016. // Get timeout
  2017. function TSMTP2000.GetTimeOut: Integer;
  2018. begin
  2019.   Result := FSocketTalk.TimeOut;
  2020. end;
  2021. // Set OnProgress event
  2022. procedure TSMTP2000.SetProgress(Value: TProgressEvent);
  2023. begin
  2024.   FSocketTalk.OnProgress := Value;
  2025. end;
  2026. // Get OnProgress event
  2027. function TSMTP2000.GetProgress: TProgressEvent;
  2028. begin
  2029.   Result := FSocketTalk.OnProgress;
  2030. end;
  2031. // Get LastResponse
  2032. function TSMTP2000.GetLastResponse: String;
  2033. begin
  2034.   Result := FSocketTalk.LastResponse;
  2035. end;
  2036. // When data from server ends
  2037. procedure TSMTP2000.EndOfData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
  2038. begin
  2039.   case SessionState of
  2040.     stConnect:
  2041.     if Copy(Data, 1, 3) = '220' then
  2042.       ServerResult := True;
  2043.     stHelo, stEhlo, stMail, stRcpt, stSendData:
  2044.     if Copy(Data, 1, 3) = '250' then
  2045.       ServerResult := True;
  2046.     stData:
  2047.     if Copy(Data, 1, 3) = '354' then
  2048.       ServerResult := True;
  2049.     stQuit:
  2050.     if Copy(Data, 1, 3) = '221' then
  2051.       ServerResult := True;
  2052.     stAuthLogin, stSMTPUser:
  2053.     if Copy(Data, 1, 3) = '334' then
  2054.       ServerResult := True;
  2055.     stSMTPPass:
  2056.     if Copy(Data, 1, 3) = '235' then
  2057.       ServerResult := True;
  2058.     stNoop: ServerResult := True;
  2059.   end;
  2060. end;
  2061. // On socket error
  2062. procedure TSMTP2000.SocketTalkError(Sender: TObject; SessionState: TSessionState; TalkError: TTalkError);
  2063. begin
  2064.   FSocketTalk.Cancel;
  2065. end;
  2066. // On data received
  2067. procedure TSMTP2000.ReceiveData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
  2068. begin
  2069.   if (StrToIntDef(Copy(Data, 1, 3), 0) >= 500) and (Copy(Data, Length(Data)-1, 2) = #13#10) then
  2070.   begin
  2071.     ServerResult := False;
  2072.     FSocketTalk.Cancel;
  2073.   end;
  2074. end;
  2075. // On socket disconnected
  2076. procedure TSMTP2000.SocketDisconnect(Sender: TObject);
  2077. begin
  2078.   FSessionConnected := False;
  2079. end;
  2080. // Connect socket
  2081. function TSMTP2000.Connect: Boolean;
  2082. var
  2083.   Buffer: String;
  2084. begin
  2085.   Result := False;
  2086.   if FSessionConnected or FSocketTalk.ClientSocket.Active then
  2087.   begin
  2088.     Exit;
  2089.   end;
  2090.   if Length(FHost) = 0 then
  2091.   begin
  2092.     Exit;
  2093.   end;
  2094.   if not IsIPAddress(FHost) then
  2095.   begin
  2096.     FSocketTalk.ClientSocket.Host := FHost;
  2097.     FSocketTalk.ClientSocket.Address := '';
  2098.   end
  2099.   else
  2100.   begin
  2101.     FSocketTalk.ClientSocket.Host := '';
  2102.     FSocketTalk.ClientSocket.Address := FHost;
  2103.   end;
  2104.   FNeedAuthentication := False;
  2105.   FSocketTalk.ClientSocket.Port := FPort;
  2106.   FSocketTalk.ForceState(stConnect);
  2107.   FSocketTalk.ClientSocket.Open;
  2108.   FSocketTalk.WaitServer;
  2109.   if FSocketTalk.ServerResult then
  2110.   begin
  2111.     case FHandshaking of
  2112.       hsAuto:
  2113.       begin
  2114.         FSessionConnected := True;
  2115.         Buffer := FSocketTalk.FLastResponse;
  2116.         Result := Ehlo;
  2117.         Buffer := Buffer + FSocketTalk.FLastResponse;
  2118.         if not Result then
  2119.         begin
  2120.           Result := Helo;
  2121.           Buffer := Buffer + FSocketTalk.FLastResponse;
  2122.         end;
  2123.         if Result then
  2124.         begin
  2125.           if AuthLogin then
  2126.           begin
  2127.             Buffer := Buffer + FSocketTalk.FLastResponse;
  2128.             Result := Login;
  2129.             Buffer := Buffer + FSocketTalk.FLastResponse;
  2130.           end;
  2131.         end;
  2132.         FSocketTalk.FLastResponse := Buffer;
  2133.       end;
  2134.       hsManual:
  2135.       begin
  2136.         Result := True;
  2137.       end;
  2138.     end;
  2139.   end;
  2140.   FSessionConnected := Result;
  2141. end;
  2142. // Sends a HELO command
  2143. function TSMTP2000.Helo: Boolean;
  2144. begin
  2145.   Result := False;
  2146.   if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
  2147.   begin
  2148.     Exit;
  2149.   end;
  2150.   FSocketTalk.Talk('HELO'#32+FSocketTalk.FClientSocket.Socket.LocalHost+#13#10, #13#10, stHelo);
  2151.   FSocketTalk.WaitServer;
  2152.   Result := FSocketTalk.ServerResult;
  2153. end;
  2154. // Sends a EHLO command
  2155. function TSMTP2000.Ehlo: Boolean;
  2156. begin
  2157.   Result := False;
  2158.   if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
  2159.   begin
  2160.     Exit;
  2161.   end;
  2162.   FSocketTalk.Talk('EHLO'#32+FSocketTalk.FClientSocket.Socket.LocalHost+#13#10, #13#10, stEhlo);
  2163.   FSocketTalk.WaitServer;
  2164.   Result := FSocketTalk.ServerResult;
  2165. end;
  2166. // Sends a AUTH LOGIN command
  2167. function TSMTP2000.AuthLogin: Boolean;
  2168. begin
  2169.   Result := False;
  2170.   if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
  2171.   begin
  2172.     Exit;
  2173.   end;
  2174.   FSocketTalk.Talk('AUTH LOGIN'#13#10, #13#10, stAuthLogin);
  2175.   FSocketTalk.WaitServer;
  2176.   FNeedAuthentication := FSocketTalk.ServerResult;
  2177.   Result := FSocketTalk.ServerResult;
  2178. end;
  2179. // Login to server
  2180. function TSMTP2000.Login: Boolean;
  2181. var
  2182.   EncUser, EncPass: String;
  2183. begin
  2184.   Result := False;
  2185.   if (not FSessionConnected) or (not FNeedAuthentication) or (not FSocketTalk.ClientSocket.Active) then
  2186.   begin
  2187.     Exit;
  2188.   end;
  2189.   EncUser := EncodeBASE64String(FUserName);
  2190.   EncPass := EncodeBASE64String(FPassword);
  2191.   FSocketTalk.Talk(EncUser+#13#10, #13#10, stSMTPUser);
  2192.   FSocketTalk.WaitServer;
  2193.   if FSocketTalk.ServerResult then
  2194.   begin
  2195.     FSocketTalk.Talk(EncPass+#13#10, #13#10, stSMTPPass);
  2196.     FSocketTalk.WaitServer;
  2197.     Result := FSocketTalk.ServerResult;
  2198.   end;
  2199. end;
  2200. // SMTP Quit
  2201. function TSMTP2000.Quit: Boolean;
  2202. begin
  2203.   Result := False;
  2204.   if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
  2205.   begin
  2206.     Exit;
  2207.   end;
  2208.   FSocketTalk.Talk('QUIT'#13#10, #13#10, stQuit);
  2209.   FSocketTalk.WaitServer;
  2210.   if FSocketTalk.ServerResult then
  2211.   begin
  2212.     FSocketTalk.ClientSocket.Close;
  2213.     FSessionConnected := False;
  2214.     Result := True;
  2215.   end;
  2216. end;
  2217. // Force disconnection
  2218. procedure TSMTP2000.Abort;
  2219. begin
  2220.   FSocketTalk.ClientSocket.Close;
  2221.   FSessionConnected := False;
  2222. end;
  2223. // Send message
  2224. function TSMTP2000.SendMessage: Boolean;
  2225. var
  2226.   sDests: String;
  2227. begin
  2228.   if not Assigned(FMailMessage) then
  2229.   begin
  2230.     Exception.CreateFmt(_E_MMUN, [Self.Name]);
  2231.     Result := False;
  2232.     Exit;
  2233.   end;
  2234.   if FMailMessage.ToList.Count > 0 then
  2235.     sDests := FMailMessage.ToList.AllAddresses;
  2236.   if FMailMessage.CcList.Count > 0 then
  2237.   begin
  2238.     if sDests <> '' then sDests := sDests + ',';
  2239.     sDests := sDests + FMailMessage.CcList.AllAddresses;
  2240.   end;
  2241.   if FMailMessage.BccList.Count > 0 then
  2242.   begin
  2243.     if sDests <> '' then sDests := sDests + ',';
  2244.     sDests := sDests + FMailMessage.BccList.AllAddresses;
  2245.   end;
  2246.   Result := SendMessageTo(FMailMessage.FromAddress, sDests);
  2247. end;
  2248. // Send message to specified recipients
  2249. function TSMTP2000.SendMessageTo(const From, Dests: String): Boolean;
  2250. var
  2251.   Loop: Integer;
  2252.   AllOk: Boolean;
  2253.   sDests: TStringList;
  2254.   sHeader: String;
  2255. begin
  2256.   Result := False;
  2257.   if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
  2258.   begin
  2259.     Exit;
  2260.   end;
  2261.   if not Assigned(FMailMessage) then
  2262.   begin
  2263.     Exception.CreateFmt(_E_MMUN, [Self.Name]);
  2264.     Exit;
  2265.   end;
  2266.   if FMailMessage.FNeedRebuild then
  2267.   begin
  2268.     Exception.CreateFmt(_E_MMNR, [Self.Name]);
  2269.     Exit;
  2270.   end;
  2271.   sDests := TStringList.Create;
  2272.   sDests.Sorted := True;
  2273.   sDests.Duplicates := dupIgnore;
  2274.   sDests.CommaText := Dests;
  2275.   if sDests.Count = 0 then
  2276.   begin
  2277.     Exception.CreateFmt(_E_NRTS, [Self.Name]);
  2278.     Exit;
  2279.   end;
  2280.   FSocketTalk.Talk('MAIL FROM: <'+From+'>'#13#10, #13#10, stMail);
  2281.   FSocketTalk.WaitServer;
  2282.   if FSocketTalk.ServerResult then
  2283.   begin
  2284.     AllOk := True;
  2285.     for Loop := 0 to sDests.Count-1 do
  2286.     begin
  2287.       FSocketTalk.Talk('RCPT TO: <'+sDests[Loop]+'>'#13#10, #13#10, stRcpt);
  2288.       FSocketTalk.WaitServer;
  2289.       if not FSocketTalk.ServerResult then
  2290.       begin
  2291.         AllOk := False;
  2292.         Break;
  2293.       end;
  2294.     end;
  2295.     if AllOk then
  2296.     begin
  2297.       FMailMessage.SetMessageId(FSocketTalk.ClientSocket.Socket.LocalAddress);
  2298.       sHeader := FMailMessage.FHeader.Text;
  2299.       FMailMessage.SetLabelValue('Bcc', '');
  2300.       FSocketTalk.Talk('DATA'#13#10, #13#10, stData);
  2301.       FSocketTalk.WaitServer;
  2302.       if FSocketTalk.ServerResult then
  2303.       begin
  2304.         FSocketTalk.PacketSize := FPacketSize;
  2305.         FSocketTalk.Talk(StringReplace(FMailMessage.MessageSource, _DATAEND1, _DATAEND2, [rfReplaceAll])+_DATAEND1, #13#10, stSendData);
  2306.         FSocketTalk.WaitServer;
  2307.         if FSocketTalk.ServerResult then
  2308.         begin
  2309.           Result := True;
  2310.         end;
  2311.       end;
  2312.       FMailMessage.FHeader.Text := sHeader;
  2313.     end;
  2314.   end;
  2315.   sDests.Free;
  2316. end;
  2317. // Send string to specified recipients
  2318. function TSMTP2000.SendStringTo(const Msg, From, Dests: String): Boolean;
  2319. var
  2320.   Loop: Integer;
  2321.   AllOk: Boolean;
  2322.   sDests: TStringList;
  2323. begin
  2324.   Result := False;
  2325.   if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
  2326.   begin
  2327.     Exit;
  2328.   end;
  2329.   sDests := TStringList.Create;
  2330.   sDests.Sorted := True;
  2331.   sDests.Duplicates := dupIgnore;
  2332.   sDests.CommaText := Dests;
  2333.   if sDests.Count = 0 then
  2334.   begin
  2335.     Exception.CreateFmt(_E_NRTS, [Self.Name]);
  2336.     Exit;
  2337.   end;
  2338.   FSocketTalk.Talk('MAIL FROM: <'+From+'>'#13#10, #13#10, stMail);
  2339.   FSocketTalk.WaitServer;
  2340.   if FSocketTalk.ServerResult then
  2341.   begin
  2342.     AllOk := True;
  2343.     for Loop := 0 to sDests.Count-1 do
  2344.     begin
  2345.       FSocketTalk.Talk('RCPT TO: <'+sDests[Loop]+'>'#13#10, #13#10, stRcpt);
  2346.       FSocketTalk.WaitServer;
  2347.       if not FSocketTalk.ServerResult then
  2348.       begin
  2349.         AllOk := False;
  2350.         Break;
  2351.       end;
  2352.     end;
  2353.     if AllOk then
  2354.     begin
  2355.       FSocketTalk.Talk('DATA'#13#10, #13#10, stData);
  2356.       FSocketTalk.WaitServer;
  2357.       if FSocketTalk.ServerResult then
  2358.       begin
  2359.         FSocketTalk.PacketSize := FPacketSize;
  2360.         FSocketTalk.Talk(StringReplace(Msg, _DATAEND1, _DATAEND2, [rfReplaceAll])+_DATAEND1, #13#10, stSendData);
  2361.         FSocketTalk.WaitServer;
  2362.         if FSocketTalk.ServerResult then
  2363.         begin
  2364.           Result := True;
  2365.         end;
  2366.       end;
  2367.     end;
  2368.   end;
  2369.   sDests.Free;
  2370. end;
  2371. // =============================================================================
  2372. function TPOP2000.GetUIDLS(List: TStrings):Boolean;
  2373. var
  2374.   I,J:integer;
  2375.   S,temp:String;
  2376. begin
  2377.   Result :=False;
  2378.   if (not FSessionConnected) or (not FSessionLogged) or (not FSocketTalk.ClientSocket.Active) then
  2379.   begin
  2380.     Exit;
  2381.   end;
  2382.   S:=SendCMD('UIDL'#13#10,stUIDL);
  2383.   result:=FSocketTalk.ServerResult;
  2384.   
  2385.   if result then
  2386.   begin
  2387.     S:= FSocketTalk.LastResponse;
  2388.    
  2389.     I:=Pos(#13#10,S);
  2390.     delete(S,1,I);
  2391.     S:=trim(S);
  2392.     while Trim(S)<>'' do
  2393.     begin
  2394.       I:=Pos(#13#10,S);
  2395.       temp:=copy(S,1,I);
  2396.       J:=pos(#32,temp);
  2397.       if J=0 then Exit;
  2398.       List.Add(copy(temp,J+1,Length(temp)-J));
  2399.       delete(S,1,I);
  2400.       S:=trim(S);
  2401.     end;
  2402.     //Result := Trim(Copy(Result, Pos(MsgNum+#32, Result)+Length(MsgNum)+1, Length(Result)));
  2403.   end;
  2404. end;
  2405. function TPOP2000.SendCMD(CMD: string;state:TSessionState): string;
  2406. begin
  2407.   Result:='';
  2408.   if (not FSessionConnected) or (not FSessionLogged) or (not FSocketTalk.ClientSocket.Active) then
  2409.   begin
  2410.     Exit;
  2411.   end;
  2412.   FSocketTalk.Talk('UIDL'#13#10, '', state);
  2413.   FSocketTalk.WaitServer;
  2414.   if FSocketTalk.ServerResult then
  2415.     result:= FSocketTalk.LastResponse;
  2416. end;
  2417. function TPOP2000.RetrieveMessageByUIDL(UIDL: String): Boolean;
  2418. var
  2419.   MailTxt: TStringList;
  2420. begin
  2421.   Result := False;
  2422.   FLastMessage := '';
  2423.   if (not FSessionConnected) or (not FSessionLogged) or (not FSocketTalk.ClientSocket.Active) then
  2424.   begin
  2425.     Exit;
  2426.   end;
  2427.   //FSocketTalk.DataSize := FSessionMessageSize[Number-1];
  2428.   FSocketTalk.Talk('UIDL'#32+UIDL+#13#10, _DATAEND1, stRetr);
  2429.   FSocketTalk.WaitServer;
  2430.   if FSocketTalk.ServerResult then
  2431.   begin
  2432.     MailTxt := TStringList.Create;
  2433.     MailTxt.Text := FSocketTalk.LastResponse;
  2434.     MailTxt.Delete(MailTxt.Count-1);
  2435.     MailTxt.Delete(0);
  2436.     FLastMessage := MailTxt.Text;
  2437.     MailTxt.Free;
  2438.     if Assigned(FMailMessage) then
  2439.     begin
  2440.       FMailMessage.Reset;
  2441.       FMailMessage.Fill(PChar(FLastMessage), True);
  2442.     end;
  2443.     Result := True;
  2444.     //if FDeleteOnRetrieve then
  2445.     //  DeleteMessage(Number);
  2446.   end;
  2447. end;
  2448. end.