Email服务器

开发平台：

Delphi

Mail2000.pas：源码内容

Exit;
FIsDecoded := True;
if FBody.Size = 0 then Exit;
Content := GetAttachInfo;
Encoding := LowerCase(GetLabelValue(_C_TE));
FDecoded.Clear;
if Encoding = _E_QP then
begin
GetMem(Buffer, FBody.Size+1);
StrLCopy(Buffer, FBody.Memory, FBody.Size);
Buffer[FBody.Size] := #0;
DecoLine := DecodeQuotedPrintable(Buffer);
FreeMem(Buffer);
GetMem(Buffer, Length(DecoLine)+1);
StrPCopy(Buffer, DecoLine);
FDecoded.Write(Buffer^, Length(DecoLine));
FreeMem(Buffer);
end
else
begin
if Encoding = _E_BA then
begin
nPos := 1;
SetLength(Data, FBody.Size);
FBody.Position := 0;
FBody.ReadBuffer(Data[1], FBody.Size);
while nPos >= 0 do
begin
DataLine(Data, DecoLine, nPos);
GetMem(Buffer, 132);
Size := DecodeLineBASE64(TrimSpace(DecoLine), Buffer);
if Size > 0 then
FDecoded.Write(Buffer^, Size);
FreeMem(Buffer);
end;
end
else
begin
if (Encoding = _E_UU) or (Encoding = _E_XU) then
begin
nPos := 1;
SetLength(Data, FBody.Size);
FBody.Position := 0;
FBody.ReadBuffer(Data[1], FBody.Size);
while nPos >= 0 do
begin
DataLine(Data, DecoLine, nPos);
GetMem(Buffer, 80);
Size := DecodeLineUUCODE(TrimSpace(DecoLine), Buffer);
FDecoded.Write(Buffer^, Size);
FreeMem(Buffer);
end;
EncodeBinary; // Convert to base64
end
else
begin
// 7bit, 8bit, binary and any other
GetMem(Buffer, FBody.Size);
FBody.Position := 0;
FBody.Read(Buffer^, FBody.Size);
FDecoded.Write(Buffer^, FBody.Size);
FreeMem(Buffer);
end;
end;
end;
end;
// Encode mail part
procedure TMailPart.Encode(const ET: TEncodingType);
begin
case ET of
etBase64: EncodeBinary;
etQuotedPrintable: EncodeText;
etNoEncoding:
begin
FDecoded.Position := 0;
FBody.Clear;
FBody.LoadFromStream(FDecoded);
SetLabelValue(_C_TE, '');
end;
end;
end;
// Encode mail part in quoted-printable
procedure TMailPart.EncodeText;
var
Buffer: String;
Encoded: String;
begin
FBody.Clear;
SetLabelValue(_C_TE, _E_QP);
if FDecoded.Size > 0 then
begin
SetLength(Buffer, FDecoded.Size);
FDecoded.Position := 0;
FDecoded.ReadBuffer(Buffer[1], FDecoded.Size);
Encoded := EncodeQuotedPrintable(Buffer, False);
FBody.Write(Encoded[1], Length(Encoded));
end;
end;
// Encode mail part in base64
procedure TMailPart.EncodeBinary;
begin
EncodeBASE64(FBody, FDecoded);
SetLabelValue(_C_TE, _E_BA);
end;
{ TMailPartList ============================================================== }
// Retrieve an item from the list
function TMailPartList.Get(const Index: Integer): TMailPart;
begin
Result := inherited Items[Index];
end;
// Finalize MailPartList
destructor TMailPartList.Destroy;
begin
inherited Destroy;
end;
{ TMailRecipients ================================================================ }
// Initialize MailRecipients
constructor TMailRecipients.Create(MailMessage: TMailMessage2000; Field: String);
begin
inherited Create;
FMessage := MailMessage;
FField := Field;
FNames := TStringList.Create;
FAddresses := TStringList.Create;
FCheck := -1;
end;
// Finalize MailRecipients
destructor TMailRecipients.Destroy;
begin
FNames.Free;
FAddresses.Free;
inherited Destroy;
end;
// Copy recipients to temporary string list
procedure TMailRecipients.HeaderToStrings;
var
Dests: String;
Loop, Occur, PL: Integer;
Quote: Boolean;
EndQuote: Char;
IsName: Boolean;
sName: String;
sAddress: String;
begin
if Length(FMessage.FHeader.Text) = FCheck then
Exit;
Occur := 0;
PL := SearchStringList(FMessage.FHeader, FField+':', Occur);
FNames.Clear;
FAddresses.Clear;
while PL >= 0 do
begin
Dests := LabelValue(FMessage.FHeader[PL]);
FCheck := Length(FMessage.FHeader.Text);
sName := '';
sAddress := '';
Quote := False;
EndQuote := #0;
IsName := True;
for Loop := 1 to Length(Dests) do
begin
if ((not Quote) and (Dests[Loop] in ['"', '(']))
or (Quote and (Dests[Loop] = EndQuote)) then
begin
case Dests[Loop] of
'"': EndQuote := '"';
'(': EndQuote := ')';
end;
Quote := not Quote;
if Quote and IsName and (sName <> '') and (sAddress = '') then
begin
sAddress := TrimSpace(sName);
sName := '';
end;
end
else
begin
if (not Quote) and (Dests[Loop] in [',', ';']) then
begin
if sAddress = '' then
begin
FNames.Add('');
FAddresses.Add(TrimSpace(sName));
end
else
begin
FNames.Add(DecodeLine7Bit(TrimSpace(sName)));
FAddresses.Add(TrimSpace(sAddress));
end;
sName := '';
sAddress := '';
IsName := True;
end;
if IsName then
begin
if Quote then
sName := sName + Dests[Loop]
else
if not (Dests[Loop] in [',', ';', '<', '>']) then
sName := sName + Dests[Loop];
end
else
begin
if (not Quote) and (not (Dests[Loop] in [',', ';', '<', '>', #32])) then
sAddress := sAddress + Dests[Loop];
end;
if (not Quote) and (Dests[Loop] = '<') then
IsName := False;
if (not Quote) and (Dests[Loop] = '>') then
IsName := True;
if Quote and (sAddress <> '') then
IsName := True;
end;
end;
if Dests <> '' then
begin
if sAddress = '' then
begin
FNames.Add('');
FAddresses.Add(TrimSpace(sName));
end
else
begin
FNames.Add(DecodeLine7Bit(TrimSpace(sName)));
FAddresses.Add(TrimSpace(sAddress));
end;
end;
Inc(Occur);
PL := SearchStringList(FMessage.FHeader, FField+':', Occur);
end;
end;
// Replace recipients with temporary string list
procedure TMailRecipients.StringsToHeader;
var
Dests: String;
Loop: Integer;
begin
repeat
FMessage.SetLabelValue(FField, '');
until SearchStringList(FMessage.FHeader, FField+':') < 0;
if FAddresses.Count > 0 then
begin
Dests := '';
for Loop := 0 to FAddresses.Count-1 do
begin
if TrimSpace(FNames[Loop]) <> '' then
Dests := Dests+'"'+EncodeLine7Bit(TrimSpace(FNames[Loop]), FMessage.FCharSet)+'"'#32'<'+TrimSpace(FAddresses[Loop])+'>'
else
Dests := Dests+'<'+TrimSpace(FAddresses[Loop])+'>';
if Loop < FAddresses.Count-1 then
Dests := Dests+','#32;
end;
FMessage.SetLabelValue(FField, Dests);
end
else
begin
FMessage.SetLabelValue(FField, '');
end;
FCheck := Length(FMessage.FHeader.Text);
end;
// Retrieve a name by index
function TMailRecipients.GetName(const Index: Integer): String;
begin
HeaderToStrings;
Result := FNames[Index];
end;
// Retrieve a address by index
function TMailRecipients.GetAddress(const Index: Integer): String;
begin
HeaderToStrings;
Result := FAddresses[Index];
end;
// Returns number of recipients
function TMailRecipients.GetCount: Integer;
begin
HeaderToStrings;
Result := FAddresses.Count;
end;
// Replace a name by index
procedure TMailRecipients.SetName(const Index: Integer; const Name: String);
begin
HeaderToStrings;
FNames[Index] := Name;
StringsToHeader;
end;
// Replace an address by index
procedure TMailRecipients.SetAddress(const Index: Integer; const Address: String);
begin
HeaderToStrings;
FAddresses[Index] := Address;
StringsToHeader;
end;
// Find an recipient by name
function TMailRecipients.FindName(const Name: String): Integer;
begin
HeaderToStrings;
Result := SearchStringList(FNames, Name);
end;
// Find an recipient by address
function TMailRecipients.FindAddress(const Address: String): Integer;
begin
HeaderToStrings;
Result := SearchStringList(FAddresses, Address);
end;
// Put all names on commatext
function TMailRecipients.GetAllNames: String;
begin
HeaderToStrings;
Result := FNames.CommaText;
end;
// Put all addresses on commatext
function TMailRecipients.GetAllAddresses: String;
begin
HeaderToStrings;
Result := FAddresses.CommaText;
end;
// Set all recipients from commatext
procedure TMailRecipients.SetAll(const Names, Addresses: String);
begin
FNames.CommaText := Names + ',';
FAddresses.CommaText := Addresses + ',';
FCheck := -1;
while FNames.Count < FAddresses.Count do
FNames.Add('');
while FAddresses.Count < FNames.Count do
FNames.Delete(FNames.Count-1);
StringsToHeader;
end;
// Add recipient names to TStrings
procedure TMailRecipients.AddNamesTo(const Str: TStrings);
begin
HeaderToStrings;
Str.AddStrings(FNames);
end;
// Add recipient addresses to TStrings
procedure TMailRecipients.AddAddressesTo(const Str: TStrings);
begin
HeaderToStrings;
Str.AddStrings(FAddresses);
end;
// Add a new recipient
procedure TMailRecipients.Add(const Name, Address: String);
begin
HeaderToStrings;
FNames.Add(Name);
FAddresses.Add(Address);
StringsToHeader;
end;
// Replace an recipient by index
procedure TMailRecipients.Replace(const Index: Integer; const Name, Address: String);
begin
HeaderToStrings;
FNames[Index] := Name;
FAddresses[Index] := Address;
StringsToHeader;
end;
// Delete an recipient by index
procedure TMailRecipients.Delete(const Index: Integer);
begin
HeaderToStrings;
FNames.Delete(Index);
FAddresses.Delete(Index);
StringsToHeader;
end;
// Delete all recipients
procedure TMailRecipients.Clear;
begin
FNames.Clear;
FAddresses.Clear;
FMessage.SetLabelValue(FField, '');
FCheck := Length(FMessage.FHeader.Text);
end;
{ TMailMessage2000 =============================================================== }
// Initialize MailMessage
constructor TMailMessage2000.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FAttachList := TMailPartList.Create;
FTextPlain := TStringList.Create;
FTextHTML := TStringList.Create;
FTextPlainPart := nil;
FTextHTMLPart := nil;
FMixedPart := nil;
FRelatedPart := nil;
FAlternativePart := nil;
FNeedRebuild := False;
FNeedNormalize := False;
FNeedFindParts := False;
FCharset := _CHARSET;
FNameCount := 0;
FOwnerMessage := Self;
FToList := TMailRecipients.Create(Self, 'To');
FCcList := TMailRecipients.Create(Self, 'Cc');
FBccList := TMailRecipients.Create(Self, 'Bcc');
FTextEncoding := etQuotedPrintable;
FAttachEncoding := etBase64;
FEmbedMethod := emContentLocation;
FContentLocationBase := 'http://localhost/';
end;
// Finalize MailMessage
destructor TMailMessage2000.Destroy;
begin
inherited Destroy;
FAttachList.Free;
FTextPlain.Free;
FTextHTML.Free;
FToList.Free;
FCcList.Free;
FBccList.Free;
end;
// Get a dest. name from a field
procedure TMailMessage2000.GetSenderData(const Field: String; var Name, Address: String);
var
Dests: String;
Loop: Integer;
Quote: Boolean;
Unknown: String;
EndQuote, Phase: Char;
begin
Dests := TrimSpace(GetLabelValue(Field));
Name := '';
Address := '';
Unknown := '';
Quote := False;
EndQuote := #0;
Phase := 'U';
for Loop := 1 to Length(Dests) do
begin
if ((not Quote) and (Dests[Loop] in ['"', '(']))
or (Quote and (Dests[Loop] = EndQuote)) then
begin
case Dests[Loop] of
'"': EndQuote := '"';
'(': EndQuote := ')';
end;
Quote := not Quote;
if Quote then
begin
if Phase = 'U' then
Address := Unknown;
Phase := 'N';
end
else
begin
Phase := 'A';
end;
end
else
begin
if (not Quote) and (Dests[Loop] = '<') then
begin
if Phase = 'U' then
Name := Unknown;
Phase := 'A';
end
else
begin
if (not Quote) and (Dests[Loop] = '>') then
begin
Phase := 'N';
end
else
begin
if Phase = 'A' then
Address := Address + Dests[Loop];
if Phase = 'N' then
Name := Name + Dests[Loop];
if Phase = 'U' then
Unknown := Unknown + Dests[Loop];
end;
end;
end;
end;
if Phase = 'U' then
Address := Unknown;
Name := DecodeLine7Bit(TrimSpace(Name));
Address := TrimSpace(Address);
end;
// Count the instances of 'Received' fields in header
function TMailMessage2000.GetReceivedCount: Integer;
begin
Result := 0;
while SearchStringList(FHeader, 'Received:', Result) >= 0 do
Inc(Result);
end;
// Retrieve a 'Received' field
function TMailMessage2000.GetReceived(const Index: Integer): TReceived;
var
Dests: String;
Loop: Integer;
Quote: Integer;
Value: String;
Field: TReceivedField;
begin
Result.From := '';
Result.By := '';
Result.Address := '';
Result.Date := 0;
Dests := Trim(Copy(FHeader[SearchStringList(FHeader, 'Received', Index)], 10, 9999))+#1;
Value := '';
Field := reNone;
Quote := 0;
for Loop := 1 to Length(Dests) do
begin
if Dests[Loop] in ['(', '['] then
Inc(Quote);
if Dests[Loop] in [')', ']'] then
Dec(Quote);
if Quote < 0 then
Quote := 0;
if (not (Dests[Loop] in ['"', '<', '>', #39, ')', ']'])) and (Quote = 0) then
begin
if (Dests[Loop] = #32) and (Field = reNone) then
begin
if LowerCase(Trim(Value)) = 'from' then
Field := reFrom;
if LowerCase(Trim(Value)) = 'by' then
Field := reBy;
if LowerCase(Trim(Value)) = 'for' then
Field := reFor;
Value := '';
end;
if Dests[Loop] in [#32, ';'] then
begin
if (Trim(Value) <> '') and (Field in [reFrom, reBy, reFor]) then
begin
case Field of
reFrom: Result.From := Trim(Value);
reBy: Result.By := Trim(Value);
reFor: Result.Address := Trim(Value);
end;
Value := '';
Field := reNone;
end;
end;
if not (Dests[Loop] in [#32, ';']) then
begin
Value := Value + Dests[Loop];
end;
if Dests[Loop] = ';' then
begin
Value := Copy(Dests, Loop+1, Length(Dests));
Result.Date := MailDateToDelphiDate(Trim(Value));
Break;
end;
end;
end;
end;
// Add a 'Received:' in message header
procedure TMailMessage2000.AddHop(const From, By, Aplic, Address: String);
var
Text: String;
begin
Text := 'Received:';
if From <> '' then
Text := Text + #32'from'#32+From;
if By <> '' then
Text := Text + #32'by'#32+By;
if Aplic <> '' then
Text := Text + #32'with'#32+Aplic;
if Address <> '' then
Text := Text + #32'for'#32'<'+Address+'>';
Text := Text + ';'#32+DelphiDateToMailDate(Now);
FHeader.Insert(0, Text);
end;
// Get the From: name
function TMailMessage2000.GetFromName: String;
var
Void: String;
begin
GetSenderData(_FFR, Result, Void);
end;
// Get the From: address
function TMailMessage2000.GetFromAddress: String;
var
Void: String;
begin
GetSenderData(_FFR, Void, Result);
end;
// Get the Reply-To: name
function TMailMessage2000.GetReplyToName: String;
var
Void: String;
begin
GetSenderData(_FRT, Result, Void);
end;
// Get the Reply-To: address
function TMailMessage2000.GetReplyToAddress: String;
var
Void: String;
begin
GetSenderData(_FRT, Void, Result);
end;
// Get the Retrun-Receipt name
function TMailMessage2000.GetReceiptName: String;
var
Void: String;
begin
GetSenderData(_DNT, Result, Void);
end;
// Get the Return-Receipt address
function TMailMessage2000.GetReceiptAddress: String;
var
Void: String;
begin
GetSenderData(_DNT, Void, Result);
end;
// Set the From: name/address
procedure TMailMessage2000.SetFrom(const Name, Address: String);
begin
if (Name <> '') and (Address <> '') then
SetLabelValue(_FFR, '"' + EncodeLine7Bit(Name, FCharset) + '" <' + Address + '>')
else
if Address <> '' then
SetLabelValue(_FFR, '<' + Address + '>')
else
SetLabelValue(_FFR, '');
end;
// Set the Reply-To: name/address
procedure TMailMessage2000.SetReplyTo(const Name, Address: String);
begin
if (Name <> '') and (Address <> '') then
SetLabelValue(_FRT, '"' + EncodeLine7Bit(Name, FCharset) + '" <' + Address + '>')
else
if Address <> '' then
SetLabelValue(_FRT, '<' + Address + '>')
else
SetLabelValue(_FRT, '');
end;
// Set the Return-Receipt name/address
procedure TMailMessage2000.SetReceipt(const Name, Address: String);
begin
if (Name <> '') and (Address <> '') then
SetLabelValue(_DNT, '"' + EncodeLine7Bit(Name, FCharset) + '" <' + Address + '>')
else
if Address <> '' then
SetLabelValue(_DNT, '<' + Address + '>')
else
SetLabelValue(_DNT, '');
end;
// Get the subject
function TMailMessage2000.GetSubject: String;
begin
try
Result := DecodeLine7Bit(GetLabelValue('Subject'));
except
on e:Exception do
MessageDlg('错误原因：' + #13#10#13#10+e.Message+#13#10, mtError, [mbOK], 0);
end;
end;
// Set the subject
procedure TMailMessage2000.SetSubject(const Subject: String);
begin
SetLabelValue('Subject', EncodeLine7Bit(Subject, FCharset))
end;
// Get the mail priority
function TMailMessage2000.GetPriority: TMailPriority;
begin
Result := TMailPriority(StrToIntDef(GetToken(0, GetLabelValue(_XPRI), #32, '("', ')"'), 3)-1);
end;
// Set the mail priority
procedure TMailMessage2000.SetPriority(const Priority: TMailPriority);
begin
SetLabelValue(_XPRI, IntToStr(Ord(Priority)+1));
end;
// Get the date in TDateTime format
function TMailMessage2000.GetDate: TDateTime;
begin
Result := MailDateToDelphiDate(TrimSpace(GetLabelValue('Date')));
end;
// Set the date in RFC822 format
procedure TMailMessage2000.SetDate(const Date: TDateTime);
begin
SetLabelValue('Date', DelphiDateToMailDate(Date));
end;
// Get message id
function TMailMessage2000.GetMessageId: String;
begin
Result := GetLabelValue(_M_ID);
end;
// Set a unique message id (the parameter is just the host)
procedure TMailMessage2000.SetMessageId(const MessageId: String);
var
IDStr: String;
begin
IDStr := '<'+FormatDateTime('yyyymmddhhnnss', Now)+'.'+TrimSpace(Format('%8x', [Random($FFFFFFFF)]))+'.'+TrimSpace(Format('%8x', [Random($FFFFFFFF)]))+'@'+MessageId+'>';
SetLabelValue(_M_ID, IDStr);
end;
// Searches for attached files and determines AttachList, TextPlain, TextHTML.
procedure TMailMessage2000.FindParts;
function GetPart(Part: TMailPart): Boolean;
function GetText(Info: String): Boolean;
var
Buffer: PChar;
begin
Result := False;
if FTextPlainPart = nil then
begin
if (Info = _T_P) or (Info = _TEX) then
begin
if Part.Decode and (Part.Decoded.Size > 0) then
begin
FTextPlainPart := Part;
GetMem(Buffer, Part.FDecoded.Size+1);
StrLCopy(Buffer, Part.FDecoded.Memory, Part.FDecoded.Size);
Buffer[Part.FDecoded.Size] := #0;
FTextPlain.SetText(Buffer);
FreeMem(Buffer);
Result := True;
end;
end;
end;
if (FTextHTMLPart = nil) and (Info = _T_H) then
begin
if Part.Decode and (Part.Decoded.Size > 0) then
begin
FTextHTMLPart := Part;
GetMem(Buffer, Part.FDecoded.Size+1);
StrLCopy(Buffer, Part.FDecoded.Memory, Part.FDecoded.Size);
Buffer[Part.FDecoded.Size] := #0;
FTextHTML.SetText(Buffer);
FreeMem(Buffer);
Result := True;
end;
end;
end;
begin
Result := True;
// Check for multipart/mixed
if (FMixedPart = nil) and (Part.GetAttachInfo = _M_M) then
begin
FMixedPart := Part;
Exit;
end;
// Check for multipart/related
if (FRelatedPart = nil) and (Part.GetAttachInfo = _M_R) then
begin
FRelatedPart := Part;
Exit;
end;
// Check for multipart/alternative
if (FAlternativePart = nil) and (Part.GetAttachInfo = _M_A) then
begin
FAlternativePart := Part;
Exit;
end;
// Check for texts (when message is only one text)
if (Part = Self) and ((Copy(Part.GetAttachInfo, 1, Length(_TXT)) = _TXT) or (Part.GetAttachInfo = _TEX)) and (FSubPartList.Count = 0) then
begin
if GetText(Part.GetAttachInfo) then
Exit;
end;
// Check for texts (when message is only one text - no mime info)
if (Part = Self) and (Part.GetAttachInfo = '') and (FSubPartList.Count = 0) then
begin
if GetText(_T_P) then
Exit;
end;
// Check for texts (when message has one text plus attachs)
if (FMixedPart <> nil) and (Part.FOwnerPart = FMixedPart) and (FAlternativePart = nil) then
begin
if GetText(Part.GetAttachInfo) then
Exit;
end;
// Check for texts (when message one text with embedded)
if (FRelatedPart <> nil) and (Part.FOwnerPart = FRelatedPart) then
begin
if GetText(Part.GetAttachInfo) then
Exit;
end;
// Check for texts (when message has alternative texts)
if (FAlternativePart <> nil) and (Part.FOwnerPart = FAlternativePart) then
begin
if GetText(Part.GetAttachInfo) then
Exit;
end;
// If everything else failed, assume attachment
if Part.FSubPartList.Count = 0 then
begin
Part.FEmbedded := Part.FOwnerPart = FRelatedPart;
FAttachList.Add(Part);
end;
end;
procedure DecodeRec(MP: TMailPart);
var
Loop: Integer;
begin
if GetPart(MP) then
begin
for Loop := 0 to MP.FSubPartList.Count-1 do
begin
DecodeRec(MP.FSubPartList[Loop]);
end;
end;
end;
begin
if not FNeedFindParts then
Exit;
FAttachList.Clear;
FTextPlainPart := nil;
FTextHTMLPart := nil;
FMixedPart := nil;
FRelatedPart := nil;
FAlternativePart := nil;
FTextPlain.Clear;
FTextHTML.Clear;
FNeedFindParts := False;
DecodeRec(Self);
end;
// Ajust parts to the Mail2000 standards
procedure TMailMessage2000.Normalize(const Kind: TNormalizer = nrFirst);
var
nLoop, nOcor: Integer;
SaveBody, TmpPart, TmpMixed, TmpRelated, TmpAlternative: TMailPart;
FName: String;
nTexts, nAttachs, nEmbedded: Integer;
procedure CreateMixed(Father: TMailPart);
begin
if Father = nil then
begin
SetLabelValue(_C_T, _M_M);
SetLabelParamValue(_C_T, _BDRY, '"'+GenerateBoundary+'_mixed"');
TmpMixed := Self;
end
else
begin
TmpMixed := TMailPart.Create(Self);
TmpMixed.FOwnerMessage := Self;
TmpMixed.FOwnerPart := Father;
TmpMixed.FParentBoundary := Father.GetBoundary;
TmpMixed.SetLabelValue(_C_T, _M_R);
TmpMixed.SetLabelParamValue(_C_T, _BDRY, '"'+GenerateBoundary+'_Mixed"');
Father.FSubPartList.Add(TmpMixed);
end;
end;
procedure CreateRelated(Father: TMailPart);
begin
if Father = nil then
begin
SetLabelValue(_C_T, _M_R);
SetLabelParamValue(_C_T, _BDRY, '"'+GenerateBoundary+'_related"');
TmpRelated := Self;
end
else
begin
TmpRelated := TMailPart.Create(Self);
TmpRelated.FOwnerMessage := Self;
TmpRelated.FOwnerPart := Father;
TmpRelated.FParentBoundary := Father.GetBoundary;
TmpRelated.SetLabelValue(_C_T, _M_R);
TmpRelated.SetLabelParamValue(_C_T, _BDRY, '"'+GenerateBoundary+'_related"');
Father.FSubPartList.Add(TmpRelated);
end;
end;
procedure CreateAlternative(Father: TMailPart);
begin
if Father = nil then
begin
SetLabelValue(_C_T, _M_A);
SetLabelParamValue(_C_T, _BDRY, '"'+GenerateBoundary+'_alternative"');
TmpAlternative := Self;
end
else
begin
TmpAlternative := TMailPart.Create(Self);
TmpAlternative.FOwnerMessage := Self;
TmpAlternative.FOwnerPart := Father;
TmpAlternative.FParentBoundary := Father.GetBoundary;
TmpAlternative.SetLabelValue(_C_T, _M_A);
TmpAlternative.SetLabelParamValue(_C_T, _BDRY, '"'+GenerateBoundary+'_alternative"');
Father.FSubPartList.Add(TmpAlternative);
end;
end;
procedure CreateTextPlain(Father: TMailPart);
begin
FTextPlainPart.Remove;
if Father = nil then
begin
SetLabelValue(_C_T, _T_P);
SetLabelValue(_C_D, _INLN);
FTextPlainPart.Decode;
FTextPlainPart.FDecoded.Position := 0;
FDecoded.LoadFromStream(FTextPlainPart.FDecoded);
Encode(FTextEncoding);
FTextPlainPart.Free;
FTextPlainPart := Self;
end
else
begin
FTextPlainPart.FOwnerPart := Father;
FTextPlainPart.FParentBoundary := Father.GetBoundary;
FTextPlainPart.SetLabelValue(_C_T, _T_P);
FTextPlainPart.SetLabelValue(_C_D, _INLN);
FTextPlainPart.Decode;
FTextPlainPart.Encode(FTextEncoding);
FTextPlainPart.SetLabelValue(_C_L, IntToStr(FTextPlainPart.FBody.Size));
FTextPlainPart.FSubPartList.Clear;
Father.FSubPartList.Add(FTextPlainPart);
end;
end;
procedure CreateTextHTML(Father: TMailPart);
begin
FTextHTMLPart.Remove;
if Father = nil then
begin
SetLabelValue(_C_T, _T_H);
SetLabelValue(_C_D, _INLN);
FTextHTMLPart.Decode;
FTextHTMLPart.FDecoded.Position := 0;
FDecoded.LoadFromStream(FTextHTMLPart.FDecoded);
Encode(FTextEncoding);
FTextHTMLPart.Free;
FTextHTMLPart := Self;
end
else
begin
FTextHTMLPart.FOwnerPart := Father;
FTextHTMLPart.FParentBoundary := Father.GetBoundary;
FTextHTMLPart.SetLabelValue(_C_T, _T_H);
FTextHTMLPart.SetLabelValue(_C_D, _INLN);
FTextHTMLPart.Decode;
FTextHTMLPart.Encode(FTextEncoding);
FTextHTMLPart.SetLabelValue(_C_L, IntToStr(FTextHTMLPart.FBody.Size));
FTextHTMLPart.FSubPartList.Clear;
Father.FSubPartList.Add(FTextHTMLPart);
end;
end;
procedure CreateAttachment(var Part: TMailPart; Father: TMailPart);
begin
Part.Remove;
if Part.GetLabelValue(_C_T) = '' then
begin
Part.SetLabelValue(_C_T, _A_OS);
end;
FName := Part.GetFileName;
if (FName = '') then
begin
FName := 'file_'+IntToStr(FNameCount)+GetMimeExtension(Part.GetLabelValue(_C_T));
Inc(FNameCount);
end;
Part.SetLabelValue(_XM2A, '"'+EncodeLine7Bit(FName, FCharSet)+'"');
if Part.FEmbedded then
begin
Part.SetLabelParamValue(_XM2A, _EMBD, 'yes');
case FEmbedMethod of
emContentID:
if Part.GetLabelValue(_C_ID) = '' then
Part.SetLabelValue(_C_ID, '<'+FName+'>');
emContentLocation:
Part.SetLabelValue(_C_LC, FContentLocationBase+FName);
end;
Part.SetLabelValue(_C_D, _INLN);
Part.FOwnerPart := TmpRelated;
Part.FParentBoundary := TmpRelated.GetBoundary;
TmpRelated.FSubPartList.Add(Part);
end
else
begin
Part.SetLabelParamValue(_XM2A, _EMBD, 'no');
if (Part.GetLabelParamValue(_C_T, _NAME) = '') then
begin
Part.SetLabelParamValue(_C_T, _NAME, '"'+EncodeLine7Bit(FName, FCharSet)+'"');
end;
if (Part.GetLabelParamValue(_C_D, _FLNM) = '') then
begin
Part.SetLabelParamValue(_C_D, _FLNM, '"'+EncodeLine7Bit(FName, FCharSet)+'"');
end;
if Father <> nil then
begin
Part.SetLabelValue(_C_D, _ATCH);
Part.FOwnerPart := Father;
Part.FParentBoundary := Father.GetBoundary;
Father.FSubPartList.Add(Part);
end
else
begin
// Search for "Content-"
nOcor := 0;
repeat
begin
nLoop := SearchStringList(Part.FHeader, _CONT, nOcor);
Inc(nOcor);
if nLoop >= 0 then
FHeader.Add(Part.FHeader[nLoop]);
end
until nLoop < 0;
// Search for "X-Mail2000-"
nOcor := 0;
repeat
begin
nLoop := SearchStringList(Part.FHeader, _X_M2, nOcor);
Inc(nOcor);
if nLoop >= 0 then
FHeader.Add(Part.FHeader[nLoop]);
end
until nLoop < 0;
if not Part.FIsDecoded then
Part.Decode;
Part.FDecoded.Position := 0;
FDecoded.LoadFromStream(Part.FDecoded);
Encode(etBase64);
FAttachList.Delete(FAttachList.IndexOf(Part));
FAttachList.Add(Self);
Part.Free;
end;
end;
end;
begin
if (not FNeedNormalize) and (Kind = nrFirst) then
Exit;
FindParts;
FNeedRebuild := True;
FNeedNormalize := False;
FNameCount := 0;
nTexts := 0;
nAttachs := 0;
nEmbedded := 0;
// What content has this mail?
case Kind of
nrAddText: Inc(nTexts);
nrAddAttach: Inc(nAttachs);
nrAddEmbedded: Inc(nEmbedded);
end;
if FTextPlainPart <> nil then
Inc(nTexts);
if FTextHTMLPart <> nil then
Inc(nTexts);
for nLoop := 0 to FAttachList.Count-1 do
if FAttachList[nLoop].FEmbedded then
Inc(nEmbedded)
else
Inc(nAttachs);
// Save current main body
if (FBody.Size > 0) then
begin
SaveBody := TMailPart.Create(Self);
SaveBody.FBody.LoadFromStream(FBody);
SaveBody.FOwnerMessage := Self;
// Copy content fields from main header
nOcor := 0;
repeat
begin
nLoop := SearchStringList(FHeader, _CONT, nOcor);
Inc(nOcor);
if nLoop >= 0 then
SaveBody.FHeader.Add(FHeader[nLoop]);
end
until nLoop < 0;
// Classify main body
if Self = FTextPlainPart then
FTextPlainPart := SaveBody
else
if Self = FTextHTMLPart then
FTextHTMLPart := SaveBody
else
if Self = FMixedPart then
FMixedPart := SaveBody
else
if Self = FRelatedPart then
FRelatedPart := SaveBody
else
if Self = FAlternativePart then
FAlternativePart := SaveBody
else
if (FSubPartList.Count = 0) then
FAttachList.Add(SaveBody)
else
SaveBody.Free;
end;
// If entire mail is an attach, remove from list.
if FAttachList.IndexOf(Self) >= 0 then
FAttachList.Delete(FAttachList.IndexOf(Self));
// Create new multiparts
SetLabelValue(_C_T, '');
SetLabelValue(_C_TE, '');
SetLabelValue(_C_D, '');
SetLabelValue(_C_ID, '');
SetLabelValue(_C_LC, '');
SetLabelValue(_C_L, '');
SetLabelValue(_M_V, '1.0');
SetLabelValue(_X_M, _XMailer);
SetLabelValue(_XM2A, '');
TmpMixed := nil;
TmpRelated := nil;
TmpAlternative := nil;
FTextFather := nil;
// There are more than one attachment?
if nAttachs > 1 then
begin
CreateMixed(nil);
FTextFather := TmpMixed;
end;
// There are texts plus attachments?
if (nAttachs > 0) and (nTexts > 0) then
begin
CreateMixed(nil);
FTextFather := TmpMixed;
end;
// There are attachments and embedded attachments?
if (nAttachs > 0) and (nEmbedded > 0) then
begin
CreateMixed(nil);
FTextFather := TmpMixed;
end;
// There are embedded attachments?
if nEmbedded > 0 then
begin
CreateRelated(TmpMixed);
FTextFather := TmpRelated;
end;
// There are more than one text?
if nTexts > 1 then
begin
CreateAlternative(FTextFather);
FTextFather := TmpAlternative;
end;
// Normalize text parts
if FTextPlainPart <> nil then
CreateTextPlain(FTextFather);
if FTextHTMLPart <> nil then
CreateTextHTML(FTextFather);
// Normalize attachments
for nLoop := 0 to FAttachList.Count-1 do
begin
TmpPart := FAttachList[nLoop];
CreateAttachment(TmpPart, TmpMixed);
end;
// Remove old multiparts
if (FAlternativePart <> nil) and (FAlternativePart <> Self) then
begin
FAlternativePart.Remove;
FAlternativePart.Free;
end;
if (FRelatedPart <> nil) and (FRelatedPart <> Self) then
begin
FRelatedPart.Remove;
FRelatedPart.Free;
end;
if (FMixedPart <> nil) and (FMixedPart <> Self) then
begin
FMixedPart.Remove;
FMixedPart.Free;
end;
FMixedPart := TmpMixed;
FRelatedPart := TmpRelated;
FAlternativePart := TmpAlternative;
end;
// Insert a text on message
procedure TMailMessage2000.PutText(Text: String; var Part: TMailPart; Content: String);
begin
if Part = nil then
Normalize(nrAddText)
else
Normalize(nrFirst);
Text := AdjustLineBreaks(Text);
if Part = nil then
begin
if FTextFather <> nil then
begin
Part := TMailPart.Create(Self);
Part.FOwnerPart := FTextFather;
Part.FOwnerMessage := Self.FOwnerMessage;
Part.FParentBoundary := FTextFather.GetBoundary;
// Keep texts on beginning of this section
if LowerCase(Content) = _T_P then
begin
FTextFather.FSubPartList.Insert(0, Part);
end
else
begin
if LowerCase(Content) = _T_H then
begin
if FTextFather.FSubPartList.Items[0].GetAttachInfo = _T_P then
begin
FTextFather.FSubPartList.Insert(1, Part);
end
else
begin
FTextFather.FSubPartList.Insert(0, Part);
end;
end
else
begin
FTextFather.FSubPartList.Add(Part);
end;
end;
end
else
begin
Part := Self;
end;
end;
Part.Decoded.Clear;
Part.Decoded.Write(Text[1], Length(Text));
Part.Encode(FTextEncoding);
Part.SetLabelValue(_C_T, Content);
Part.SetLabelParamValue(_C_T, _CSET, '"'+FCharset+'"');
Part.SetLabelValue(_C_D, _INLN);
Part.SetLabelValue(_C_L, IntToStr(Part.FBody.Size));
FNeedRebuild := True;
end;
// Remove a text from message
procedure TMailMessage2000.RemoveText(var Part: TMailPart);
begin
Normalize(nrFirst);
if Part <> nil then
begin
if Part <> Self then
begin
Part.Remove;
Part.Free;
end
else
begin
FBody.Clear;
FDecoded.Clear;
SetLabelValue(_C_T, '');
SetLabelValue(_C_TE, '');
SetLabelValue(_C_D, '');
SetLabelValue(_C_L, '');
SetLabelValue(_XM2A, '');
end;
end;
Part := nil;
Normalize(nrForce);
FNeedRebuild := True;
end;
// Replace or create a mailpart for text/plain
procedure TMailMessage2000.SetTextPlain(const Text: String);
begin
PutText(Text, FTextPlainPart, _T_P);
FTextPlain.Text := Text;
end;
// Replace or create a mailpart for text/html
procedure TMailMessage2000.SetTextHTML(const Text: String);
begin
PutText(Text, FTextHTMLPart, _T_H);
FTextHTML.Text := Text;
end;
// Remove text/plain mailpart
procedure TMailMessage2000.RemoveTextPlain;
begin
if FTextPlainPart <> nil then
begin
RemoveText(FTextPlainPart);
FTextPlain.Clear;
end;
end;
// Remove text/html mailpart
procedure TMailMessage2000.RemoveTextHTML;
begin
if FTextHTMLPart <> nil then
begin
RemoveText(FTextHTMLPart);
FTextHTML.Clear;
end;
end;
// Create a mailpart and encode the file
procedure TMailMessage2000.AttachFile(const FileName: String; const ContentType: String = ''; const IsEmbedded: Boolean = False);
var
MemFile: TMemoryStream;
begin
MemFile := TMemoryStream.Create;
MemFile.LoadFromFile(FileName);
AttachStream(MemFile, FileName, ContentType, IsEmbedded);
MemFile.Free;
end;
// Create a mailpart and encode the string
procedure TMailMessage2000.AttachString(const Text, FileName: String; const ContentType: String = ''; const IsEmbedded: Boolean = False);
var
MemFile: TMemoryStream;
begin
MemFile := TMemoryStream.Create;
MemFile.WriteBuffer(Text[1], Length(Text));
AttachStream(MemFile, FileName, ContentType, IsEmbedded);
MemFile.Free;
end;
// Create a mailpart and encode the stream
procedure TMailMessage2000.AttachStream(const AStream: TStream; const FileName: String; const ContentType: String = ''; const IsEmbedded: Boolean = False);
var
Part, Father: TMailPart;
begin
if IsEmbedded then
begin
Normalize(nrAddEmbedded);
Father := FRelatedPart;
end
else
begin
Normalize(nrAddAttach);
Father := FMixedPart;
end;
if Father <> nil then
begin
Part := TMailPart.Create(Self);
Part.FOwnerMessage := Self;
Part.FOwnerPart := Father;
Part.FParentBoundary := Father.GetBoundary;
Father.FSubPartList.Add(Part);
end
else
begin
Part := Self;
end;
AStream.Position := 0;
Part.Decoded.LoadFromStream(AStream);
Part.Decoded.Position := 0;
Part.Encode(FAttachEncoding);
if ContentType = '' then
Part.SetLabelValue(_C_T, GetMimeType(ExtractFileName(FileName)))
else
Part.SetLabelValue(_C_T, ContentType);
Part.SetLabelValue(_XM2A, '"'+EncodeLine7Bit(ExtractFileName(FileName), FCharSet)+'"');
Part.SetLabelValue(_C_L, IntToStr(Part.FBody.Size));
Part.FEmbedded := IsEmbedded;
if IsEmbedded then
begin
Part.SetLabelValue(_C_D, _INLN);
Part.SetLabelParamValue(_XM2A, _EMBD, 'yes');
case FEmbedMethod of
emContentID:
Part.SetLabelValue(_C_ID, '<'+ ExtractFileName(FileName) +'>');
emContentLocation:
Part.SetLabelValue(_C_LC, FContentLocationBase + ExtractFileName(FileName));
end;
end
else
begin
Part.SetLabelValue(_C_D, _ATCH);
Part.SetLabelParamValue(_C_T, _NAME, '"'+EncodeLine7Bit(ExtractFileName(FileName), FCharSet)+'"');
Part.SetLabelParamValue(_C_D, _FLNM, '"'+EncodeLine7Bit(ExtractFileName(FileName), FCharSet)+'"');
Part.SetLabelParamValue(_XM2A, _EMBD, 'no');
end;
FAttachList.Add(Part);
FNeedRebuild := True;
end;
// Remove attached file from message
procedure TMailMessage2000.DetachFile(const FileName: String);
var
nLoop: Integer;
begin
Normalize(nrFirst);
for nLoop := 0 to FAttachList.Count-1 do
begin
if LowerCase(FAttachList[nLoop].FileName) = LowerCase(ExtractFileName(FileName)) then
begin
if FAttachList[nLoop] <> Self then
begin
FAttachList[nLoop].Remove;
FAttachList[nLoop].Free;
end
else
begin
SetLabelValue(_C_T, '');
SetLabelValue(_C_TE, '');
SetLabelValue(_C_D, '');
SetLabelValue(_C_L, '');
SetLabelValue(_C_ID, '');
SetLabelValue(_C_LC, '');
SetLabelValue(_XM2A, '');
FBody.Clear;
FDecoded.Clear;
end;
FAttachList.Delete(nLoop);
FNeedRebuild := True;
Break;
end;
end;
if not FNeedRebuild then
raise Exception.CreateFmt(_E_ATFN, [Self.Name, FileName])
else
Normalize(nrForce);
end;
// Remove attached file from message by AttachList index
procedure TMailMessage2000.DetachFileIndex(const Index: Integer);
begin
Normalize(nrFirst);
if (Index < FAttachList.Count) and (Index >= 0) then
begin
if FAttachList[Index] <> Self then
begin
FAttachList[Index].Remove;
FAttachList[Index].Free;
end
else
begin
SetLabelValue(_C_T, '');
SetLabelValue(_C_TE, '');
SetLabelValue(_C_D, '');
SetLabelValue(_C_L, '');
SetLabelValue(_C_ID, '');
SetLabelValue(_C_LC, '');
SetLabelValue(_XM2A, '');
FBody.Clear;
FDecoded.Clear;
end;
FAttachList.Delete(Index);
FNeedRebuild := True;
Normalize(nrForce);
end
else
raise Exception.CreateFmt(_E_ATIN, [Self.Name]);
end;
// Find the part containing the specified attachment
function TMailMessage2000.GetAttach(const FileName: String): TMailPart;
var
nLoop: Integer;
begin
Normalize(nrFirst);
Result := nil;
for nLoop := 0 to FAttachList.Count-1 do
begin
if LowerCase(FAttachList[nLoop].FileName) = LowerCase(FileName) then
begin
Result := FAttachList[nLoop];
Break;
end;
end;
end;
// Rebuild body text according to the mailparts
procedure TMailMessage2000.RebuildBody;
var
sLine: String;
procedure RebuildBodyRec(MP: TMailPart);
var
Loop: Integer;
Line: Integer;
Data: String;
nPos: Integer;
begin
for Loop := 0 to MP.SubPartList.Count-1 do
begin
sLine := #13#10;
FBody.Write(sLine[1], Length(sLine));
sLine := '--'+MP.SubPartList[Loop].FParentBoundary+#13#10;
FBody.Write(sLine[1], Length(sLine));
for Line := 0 to MP.SubPartList[Loop].FHeader.Count-1 do
begin
if Length(MP.SubPartList[Loop].FHeader[Line]) > 0 then
begin
sLine := MP.SubPartList[Loop].FHeader[Line]+#13#10;
FBody.Write(sLine[1], Length(sLine));
end;
end;
sLine := #13#10;
FBody.Write(sLine[1], Length(sLine));
if MP.SubPartList[Loop].SubPartList.Count > 0 then
begin
RebuildBodyRec(MP.SubPartList[Loop]);
end
else
begin
SetLength(Data, MP.SubPartList[Loop].FBody.Size);
if MP.SubPartList[Loop].FBody.Size > 0 then
begin
MP.SubPartList[Loop].FBody.Position := 0;
MP.SubPartList[Loop].FBody.ReadBuffer(Data[1], MP.SubPartList[Loop].FBody.Size);
nPos := 1;
while nPos >= 0 do
begin
DataLine(Data, sLine, nPos);
sLine := sLine;
FBody.Write(sLine[1], Length(sLine));
end;
end;
end;
end;
if MP.SubPartList.Count > 0 then
begin
sLine := #13#10;
FBody.Write(sLine[1], Length(sLine));
sLine := '--'+MP.SubPartList[0].FParentBoundary+'--'#13#10;
FBody.Write(sLine[1], Length(sLine));
end;
end;
begin
if not FNeedRebuild then
Exit;
if SubPartList.Count > 0 then
begin
FBody.Clear;
sLine := _MIME_Msg;
FBody.Write(sLine[1], Length(sLine));
RebuildBodyRec(Self);
end;
SetLabelValue(_C_L, IntToStr(FBody.Size));
FNeedRebuild := False;
end;
// Empty data stored in the object
procedure TMailMessage2000.Reset;
var
Loop: Integer;
begin
for Loop := 0 to FSubPartList.Count-1 do
FSubPartList.Items[Loop].Destroy;
FHeader.Clear;
FBody.Clear;
FDecoded.Clear;
FSubPartList.Clear;
FAttachList.Clear;
FTextPlain.Clear;
FTextHTML.Clear;
FTextPlainPart := nil;
FTextHTMLPart := nil;
FMixedPart := nil;
FRelatedPart := nil;
FAlternativePart := nil;
FNeedRebuild := False;
FNeedNormalize := False;
FNeedFindParts := False;
FNameCount := 0;
end;
{ TSocketTalk =================================================================== }
// Initialize TSocketTalk
constructor TSocketTalk.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FClientSocket := TClientSocket.Create(Self);
FClientSocket.ClientType := ctNonBlocking;
FClientSocket.OnRead := SocketRead;
FClientSocket.OnDisconnect := SocketDisconnect;
FClientSocket.Socket.OnErrorEvent := SocketError;
FTimer := TTimer.Create(Self);
FTimer.Enabled := False;
FTimer.OnTimer := Timer;
FTimeOut := 60;
FLastResponse := '';
FExpectedEnd := '';
FDataSize := 0;
FPacketSize := 0;
FTalkError := teNoError;
end;
// Finalize TSocketTalk
destructor TSocketTalk.Destroy;
begin
FClientSocket.Free;
FTimer.Free;
inherited Destroy;
end;
// Occurs when data is comming from the socket
procedure TSocketTalk.SocketRead(Sender: TObject; Socket: TCustomWinSocket);
var
Buffer: String;
BufLen: Integer;
begin
SetLength(Buffer, Socket.ReceiveLength);
BufLen := Socket.ReceiveBuf(Buffer[1], Length(Buffer));
FLastResponse := FLastResponse + Copy(Buffer, 1, BufLen);
FTalkError := teNoError;
FTimer.Enabled := False;
if Assigned(FOnReceiveData) then
begin
FOnReceiveData(Self, FSessionState, Buffer, FServerResult);
end;
if (FDataSize > 0) and Assigned(FOnProgress) then
begin
FOnProgress(Self.Owner, FDataSize, Length(FLastResponse));
end;
if (FExpectedEnd = '') or (Copy(FLastResponse, Length(FLastResponse)-Length(FExpectedEnd)+1, Length(FExpectedEnd)) = FExpectedEnd) then
begin
FTalkError := teNoError;
FDataSize := 0;
FExpectedEnd := '';
FWaitingServer := False;
if Assigned(FOnEndOfData) then
begin
FOnEndOfData(Self, FSessionState, FLastResponse, FServerResult);
end;
FSessionState := stNone;
end
else
begin
FTimer.Enabled := True;
end;
end;
// Occurs when socket is disconnected
procedure TSocketTalk.SocketDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
if Assigned(FOnDisconnect) then
FOnDisconnect(Self);
FTimer.Enabled := False;
FWaitingServer := False;
FSessionState := stNone;
FExpectedEnd := '';
FDataSize := 0;
FPacketSize := 0;
end;
// Occurs on socket error
procedure TSocketTalk.SocketError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
FTimer.Enabled := False;
FTalkError := TTalkError(Ord(ErrorEvent));
FDataSize := 0;
FExpectedEnd := '';
FWaitingServer := False;
FServerResult := False;
if Assigned(FOnSocketTalkError) then
begin
FOnSocketTalkError(Self, FSessionState, FTalkError);
end;
FSessionState := stNone;
ErrorCode := 0;
end;
// Occurs on timeout
procedure TSocketTalk.Timer(Sender: TObject);
begin
FTimer.Enabled := False;
FTalkError := teTimeout;
FDataSize := 0;
FExpectedEnd := '';
FWaitingServer := False;
FServerResult := False;
if Assigned(FOnSocketTalkError) then
begin
FOnSocketTalkError(Self, FSessionState, FTalkError);
end;
FSessionState := stNone;
end;
// Cancel the waiting for server response
procedure TSocketTalk.Cancel;
begin
FTimer.Enabled := False;
FTalkError := teNoError;
FSessionState := stNone;
FExpectedEnd := '';
FDataSize := 0;
FWaitingServer := False;
FServerResult := False;
end;
// Inform that the data comming belongs
procedure TSocketTalk.ForceState(SessionState: TSessionState);
begin
FExpectedEnd := '';
FLastResponse := '';
FTimer.Interval := FTimeOut * 1000;
FTimer.Enabled := True;
FDataSize := 0;
FTalkError := teNoError;
FSessionState := SessionState;
FWaitingServer := True;
FServerResult := False;
end;
// Send a command to server
procedure TSocketTalk.Talk(Buffer, EndStr: String; SessionState: TSessionState);
var
nPos: Integer;
nLen: Integer;
begin
FExpectedEnd := EndStr;
FSessionState := SessionState;
FLastResponse := '';
FTimer.Interval := FTimeOut * 1000;
FTalkError := teNoError;
FWaitingServer := True;
FServerResult := False;
nPos := 1;
if (FPacketSize > 0) and (Length(Buffer) > FPacketSize) then
begin
if Assigned(OnProgress) then
OnProgress(Self.Owner, Length(Buffer), 0);
while nPos <= Length(Buffer) do
begin
Application.ProcessMessages;
if (nPos+FPacketSize-1) > Length(Buffer) then
nLen := Length(Buffer)-nPos+1
else
nLen := FPacketSize;
FTimer.Enabled := True;
while (FClientSocket.Socket.SendBuf(Buffer[nPos], nLen) = -1) do
Sleep(10);
FTimer.Enabled := False;
nPos := nPos + nLen;
if Assigned(OnProgress) then
OnProgress(Self.Owner, Length(Buffer), nPos-1);
end;
if Assigned(OnProgress) then
OnProgress(Self.Owner, Length(Buffer), Length(Buffer));
end
else
begin
while (FClientSocket.Socket.SendBuf(Buffer[1], Length(Buffer)) = -1 )
do Sleep (10);
end;
FPacketSize := 0;
end;
// Wait for server response
// by Rene de Jong (rmdejong@ism.nl)
procedure TSocketTalk.WaitServer;
begin
FTimer.Interval := FTimeOut * 1000;
while FWaitingServer and (not FServerResult) do
begin
FTimer.Enabled := True;
Application.ProcessMessages;
end;
FTimer.Enabled := False;
end;
{ TPOP2000 ====================================================================== }
// Initialize TPOP2000
constructor TPOP2000.Create;
begin
FSocketTalk := TSocketTalk.Create(Self);
FSocketTalk.OnEndOfData := EndOfData;
FSocketTalk.OnSocketTalkError := SocketTalkError;
FSocketTalk.OnReceiveData := ReceiveData;
FSocketTalk.OnDisconnect := SocketDisconnect;
FHost := '';
FPort := 110;
FUserName := '';
FPassword := '';
FSessionMessageCount := -1;
FSessionConnected := False;
FSessionLogged := False;
FMailMessage := nil;
FDeleteOnRetrieve := False;
SetLength(FSessionMessageSize, 0);
inherited Create(AOwner);
end;
// Finalize TPOP2000
destructor TPOP2000.Destroy;
begin
FSocketTalk.Free;
SetLength(FSessionMessageSize, 0);
inherited Destroy;
end;
// Set timeout
procedure TPOP2000.SetTimeOut(Value: Integer);
begin
FSocketTalk.TimeOut := Value;
end;
// Get timeout
function TPOP2000.GetTimeOut: Integer;
begin
Result := FSocketTalk.TimeOut;
end;
// Set OnProgress event
procedure TPOP2000.SetProgress(Value: TProgressEvent);
begin
FSocketTalk.OnProgress := Value;
end;
// Get OnProgress event
function TPOP2000.GetProgress: TProgressEvent;
begin
Result := FSocketTalk.OnProgress;
end;
// Get LastResponse
function TPOP2000.GetLastResponse: String;
begin
Result := FSocketTalk.LastResponse;
end;
// When data from server ends
procedure TPOP2000.EndOfData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
begin
case SessionState of
stConnect, stUser, stPass, stStat, stList, stRetr, stQuit, stDele, stUIDL:
if Copy(Data, 1, 3) = '+OK' then
ServerResult := True;
end;
end;
// On socket error
procedure TPOP2000.SocketTalkError(Sender: TObject; SessionState: TSessionState; TalkError: TTalkError);
begin
FSocketTalk.Cancel;
end;
// On data received
procedure TPOP2000.ReceiveData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
begin
if (Copy(Data, 1, 4) = '-ERR') and (Copy(Data, Length(Data)-1, 2) = #13#10) then
begin
ServerResult := False;
FSocketTalk.Cancel;
end;
end;
// On socket disconnected
procedure TPOP2000.SocketDisconnect(Sender: TObject);
begin
FSessionMessageCount := -1;
FSessionConnected := False;
FSessionLogged := False;
SetLength(FSessionMessageSize, 0);
end;
// Connect socket
function TPOP2000.Connect: Boolean;
begin
if FSessionConnected or FSocketTalk.ClientSocket.Active then
begin
Result := False;
Exit;
end;
if Length(FHost) = 0 then
begin
Result := False;
Exit;
end;
if not IsIPAddress(FHost) then
begin
FSocketTalk.ClientSocket.Host := FHost;
FSocketTalk.ClientSocket.Address := '';
end
else
begin
FSocketTalk.ClientSocket.Host := '';
FSocketTalk.ClientSocket.Address := FHost;
end;
FSocketTalk.ClientSocket.Port := FPort;
FSocketTalk.ForceState(stConnect);
FSocketTalk.ClientSocket.Open;
FSocketTalk.WaitServer;
FSessionConnected := FSocketTalk.ServerResult;
Result := FSocketTalk.ServerResult;
end;
// POP3 Logon
function TPOP2000.Login: Boolean;
var
MsgList: TStringList;
Loop: Integer;
cStat: String;
begin
Result := False;
if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
begin
Exit;
end;
FSocketTalk.Talk('USER'#32+FUserName+#13#10, #13#10, stUser);
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
begin
FSocketTalk.Talk('PASS'#32+FPassword+#13#10, #13#10, stPass);
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
begin
FSessionLogged := True;
FSocketTalk.Talk('LIST'#13#10, _DATAEND1, stList);
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
begin
MsgList := TStringList.Create;
MsgList.Text := FSocketTalk.LastResponse;
if MsgList.Count > 2 then
begin
cStat := TrimSpace(MsgList[MsgList.Count-2]);
FSessionMessageCount := StrToIntDef(Copy(cStat, 1, Pos(#32, cStat)-1), -1);
if FSessionMessageCount > 0 then
begin
for Loop := 1 to MsgList.Count-2 do
begin
cStat := TrimSpace(MsgList[Loop]);
cStat := Copy(cStat, 1, Pos(#32, cStat)-1);
SetLength(FSessionMessageSize, StrToInt(cStat)+1);
if StrToIntDef(cStat, 0) > 0 then
FSessionMessageSize[StrToInt(cStat)] := StrToIntDef(Copy(MsgList[Loop], Pos(#32, MsgList[Loop])+1, 99), 0);
end;
FSessionMessageSize[0] := 0;
end;
end
else
begin
FSessionMessageCount := 0;
SetLength(FSessionMessageSize, 0);
end;
MsgList.Free;
end;
end;
end;
Result := FSessionLogged;
end;
// POP3 Quit
function TPOP2000.Quit: Boolean;
begin
Result := False;
if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
begin
Exit;
end;
FSocketTalk.Talk('QUIT'#13#10, #13#10, stQuit);
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
begin
FSocketTalk.ClientSocket.Close;
FSessionConnected := False;
FSessionLogged := False;
FSessionMessageCount := -1;
Result := True;
end;
end;
// Force disconnection
procedure TPOP2000.Abort;
begin
FSocketTalk.ClientSocket.Close;
FSessionConnected := False;
FSessionLogged := False;
FSessionMessageCount := -1;
end;
// Retrieve message#
function TPOP2000.RetrieveMessage(Number: Integer): Boolean;
var
MailTxt: TStringList;
begin
Result := False;
FLastMessage := '';
if (not FSessionConnected) or (not FSessionLogged) or (not FSocketTalk.ClientSocket.Active) then
begin
Exit;
end;
FSocketTalk.DataSize := FSessionMessageSize[Number-1];
FSocketTalk.Talk('RETR'#32+IntToStr(Number)+#13#10, _DATAEND1, stRetr);
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
begin
MailTxt := TStringList.Create;
MailTxt.Text := FSocketTalk.LastResponse;
MailTxt.Delete(MailTxt.Count-1);
MailTxt.Delete(0);
FLastMessage := MailTxt.Text;
MailTxt.Free;
if Assigned(FMailMessage) then
begin
FMailMessage.Reset;
FMailMessage.Fill(PChar(FLastMessage), True);
end;
Result := True;
if FDeleteOnRetrieve then
DeleteMessage(Number);
end;
end;
// Retrieve message# (only header)
function TPOP2000.RetrieveHeader(Number: Integer; Lines: Integer = 0): Boolean;
var
MailTxt: TStringList;
begin
Result := False;
FLastMessage := '';
if (not FSessionConnected) or (not FSessionLogged) or (not FSocketTalk.ClientSocket.Active) then
begin
Exit;
end;
FSocketTalk.DataSize := FSessionMessageSize[Number-1];
FSocketTalk.Talk('TOP'#32+IntToStr(Number)+#32+IntToStr(Lines)+#13#10, _DATAEND1, stRetr);
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
begin
MailTxt := TStringList.Create;
MailTxt.Text := FSocketTalk.LastResponse;
MailTxt.Delete(MailTxt.Count-1);
MailTxt.Delete(0);
FLastMessage := MailTxt.Text;
MailTxt.Free;
if Assigned(FMailMessage) then
begin
FMailMessage.Reset;
FMailMessage.FHeader.Text := PChar(FLastMessage);
end;
Result := True;
end;
end;
// Delete message#
function TPOP2000.DeleteMessage(Number: Integer): Boolean;
begin
Result := False;
if (not FSessionConnected) or (not FSessionLogged) or (not FSocketTalk.ClientSocket.Active) then
begin
Exit;
end;
FSocketTalk.Talk('DELE'#32+IntToStr(Number)+#13#10, #13#10, stDele);
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
begin
Result := True;
end;
end;
// Get UIDL from message#
function TPOP2000.GetUIDL(Number: Integer): String;
var
MsgNum: String;
begin
Result := '';
MsgNum := IntToStr(Number);
if (not FSessionConnected) or (not FSessionLogged) or (not FSocketTalk.ClientSocket.Active) then
begin
Exit;
end;
FSocketTalk.Talk('UIDL'#32+MsgNum+#13#10, #13#10, stUIDL);
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
begin
Result := FSocketTalk.LastResponse;
Result := Trim(Copy(Result, Pos(MsgNum+#32, Result)+Length(MsgNum)+1, Length(Result)));
end;
end;
{ TSMTP2000 ====================================================================== }
// Initialize TSMTP2000
constructor TSMTP2000.Create;
begin
FSocketTalk := TSocketTalk.Create(Self);
FSocketTalk.OnEndOfData := EndOfData;
FSocketTalk.OnSocketTalkError := SocketTalkError;
FSocketTalk.OnReceiveData := ReceiveData;
FSocketTalk.OnDisconnect := SocketDisconnect;
FHost := '';
FPort := 25;
FSessionConnected := False;
FPacketSize := 102400;
FUserName := '';
FPassword := '';
FHandshaking := hsAuto;
inherited Create(AOwner);
end;
// Finalize TSMTP2000
destructor TSMTP2000.Destroy;
begin
FSocketTalk.Free;
inherited Destroy;
end;
// Set timeout
procedure TSMTP2000.SetTimeOut(Value: Integer);
begin
FSocketTalk.TimeOut := Value;
end;
// Get timeout
function TSMTP2000.GetTimeOut: Integer;
begin
Result := FSocketTalk.TimeOut;
end;
// Set OnProgress event
procedure TSMTP2000.SetProgress(Value: TProgressEvent);
begin
FSocketTalk.OnProgress := Value;
end;
// Get OnProgress event
function TSMTP2000.GetProgress: TProgressEvent;
begin
Result := FSocketTalk.OnProgress;
end;
// Get LastResponse
function TSMTP2000.GetLastResponse: String;
begin
Result := FSocketTalk.LastResponse;
end;
// When data from server ends
procedure TSMTP2000.EndOfData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
begin
case SessionState of
stConnect:
if Copy(Data, 1, 3) = '220' then
ServerResult := True;
stHelo, stEhlo, stMail, stRcpt, stSendData:
if Copy(Data, 1, 3) = '250' then
ServerResult := True;
stData:
if Copy(Data, 1, 3) = '354' then
ServerResult := True;
stQuit:
if Copy(Data, 1, 3) = '221' then
ServerResult := True;
stAuthLogin, stSMTPUser:
if Copy(Data, 1, 3) = '334' then
ServerResult := True;
stSMTPPass:
if Copy(Data, 1, 3) = '235' then
ServerResult := True;
stNoop: ServerResult := True;
end;
end;
// On socket error
procedure TSMTP2000.SocketTalkError(Sender: TObject; SessionState: TSessionState; TalkError: TTalkError);
begin
FSocketTalk.Cancel;
end;
// On data received
procedure TSMTP2000.ReceiveData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
begin
if (StrToIntDef(Copy(Data, 1, 3), 0) >= 500) and (Copy(Data, Length(Data)-1, 2) = #13#10) then
begin
ServerResult := False;
FSocketTalk.Cancel;
end;
end;
// On socket disconnected
procedure TSMTP2000.SocketDisconnect(Sender: TObject);
begin
FSessionConnected := False;
end;
// Connect socket
function TSMTP2000.Connect: Boolean;
var
Buffer: String;
begin
Result := False;
if FSessionConnected or FSocketTalk.ClientSocket.Active then
begin
Exit;
end;
if Length(FHost) = 0 then
begin
Exit;
end;
if not IsIPAddress(FHost) then
begin
FSocketTalk.ClientSocket.Host := FHost;
FSocketTalk.ClientSocket.Address := '';
end
else
begin
FSocketTalk.ClientSocket.Host := '';
FSocketTalk.ClientSocket.Address := FHost;
end;
FNeedAuthentication := False;
FSocketTalk.ClientSocket.Port := FPort;
FSocketTalk.ForceState(stConnect);
FSocketTalk.ClientSocket.Open;
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
begin
case FHandshaking of
hsAuto:
begin
FSessionConnected := True;
Buffer := FSocketTalk.FLastResponse;
Result := Ehlo;
Buffer := Buffer + FSocketTalk.FLastResponse;
if not Result then
begin
Result := Helo;
Buffer := Buffer + FSocketTalk.FLastResponse;
end;
if Result then
begin
if AuthLogin then
begin
Buffer := Buffer + FSocketTalk.FLastResponse;
Result := Login;
Buffer := Buffer + FSocketTalk.FLastResponse;
end;
end;
FSocketTalk.FLastResponse := Buffer;
end;
hsManual:
begin
Result := True;
end;
end;
end;
FSessionConnected := Result;
end;
// Sends a HELO command
function TSMTP2000.Helo: Boolean;
begin
Result := False;
if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
begin
Exit;
end;
FSocketTalk.Talk('HELO'#32+FSocketTalk.FClientSocket.Socket.LocalHost+#13#10, #13#10, stHelo);
FSocketTalk.WaitServer;
Result := FSocketTalk.ServerResult;
end;
// Sends a EHLO command
function TSMTP2000.Ehlo: Boolean;
begin
Result := False;
if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
begin
Exit;
end;
FSocketTalk.Talk('EHLO'#32+FSocketTalk.FClientSocket.Socket.LocalHost+#13#10, #13#10, stEhlo);
FSocketTalk.WaitServer;
Result := FSocketTalk.ServerResult;
end;
// Sends a AUTH LOGIN command
function TSMTP2000.AuthLogin: Boolean;
begin
Result := False;
if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
begin
Exit;
end;
FSocketTalk.Talk('AUTH LOGIN'#13#10, #13#10, stAuthLogin);
FSocketTalk.WaitServer;
FNeedAuthentication := FSocketTalk.ServerResult;
Result := FSocketTalk.ServerResult;
end;
// Login to server
function TSMTP2000.Login: Boolean;
var
EncUser, EncPass: String;
begin
Result := False;
if (not FSessionConnected) or (not FNeedAuthentication) or (not FSocketTalk.ClientSocket.Active) then
begin
Exit;
end;
EncUser := EncodeBASE64String(FUserName);
EncPass := EncodeBASE64String(FPassword);
FSocketTalk.Talk(EncUser+#13#10, #13#10, stSMTPUser);
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
begin
FSocketTalk.Talk(EncPass+#13#10, #13#10, stSMTPPass);
FSocketTalk.WaitServer;
Result := FSocketTalk.ServerResult;
end;
end;
// SMTP Quit
function TSMTP2000.Quit: Boolean;
begin
Result := False;
if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
begin
Exit;
end;
FSocketTalk.Talk('QUIT'#13#10, #13#10, stQuit);
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
begin
FSocketTalk.ClientSocket.Close;
FSessionConnected := False;
Result := True;
end;
end;
// Force disconnection
procedure TSMTP2000.Abort;
begin
FSocketTalk.ClientSocket.Close;
FSessionConnected := False;
end;
// Send message
function TSMTP2000.SendMessage: Boolean;
var
sDests: String;
begin
if not Assigned(FMailMessage) then
begin
Exception.CreateFmt(_E_MMUN, [Self.Name]);
Result := False;
Exit;
end;
if FMailMessage.ToList.Count > 0 then
sDests := FMailMessage.ToList.AllAddresses;
if FMailMessage.CcList.Count > 0 then
begin
if sDests <> '' then sDests := sDests + ',';
sDests := sDests + FMailMessage.CcList.AllAddresses;
end;
if FMailMessage.BccList.Count > 0 then
begin
if sDests <> '' then sDests := sDests + ',';
sDests := sDests + FMailMessage.BccList.AllAddresses;
end;
Result := SendMessageTo(FMailMessage.FromAddress, sDests);
end;
// Send message to specified recipients
function TSMTP2000.SendMessageTo(const From, Dests: String): Boolean;
var
Loop: Integer;
AllOk: Boolean;
sDests: TStringList;
sHeader: String;
begin
Result := False;
if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
begin
Exit;
end;
if not Assigned(FMailMessage) then
begin
Exception.CreateFmt(_E_MMUN, [Self.Name]);
Exit;
end;
if FMailMessage.FNeedRebuild then
begin
Exception.CreateFmt(_E_MMNR, [Self.Name]);
Exit;
end;
sDests := TStringList.Create;
sDests.Sorted := True;
sDests.Duplicates := dupIgnore;
sDests.CommaText := Dests;
if sDests.Count = 0 then
begin
Exception.CreateFmt(_E_NRTS, [Self.Name]);
Exit;
end;
FSocketTalk.Talk('MAIL FROM: <'+From+'>'#13#10, #13#10, stMail);
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
begin
AllOk := True;
for Loop := 0 to sDests.Count-1 do
begin
FSocketTalk.Talk('RCPT TO: <'+sDests[Loop]+'>'#13#10, #13#10, stRcpt);
FSocketTalk.WaitServer;
if not FSocketTalk.ServerResult then
begin
AllOk := False;
Break;
end;
end;
if AllOk then
begin
FMailMessage.SetMessageId(FSocketTalk.ClientSocket.Socket.LocalAddress);
sHeader := FMailMessage.FHeader.Text;
FMailMessage.SetLabelValue('Bcc', '');
FSocketTalk.Talk('DATA'#13#10, #13#10, stData);
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
begin
FSocketTalk.PacketSize := FPacketSize;
FSocketTalk.Talk(StringReplace(FMailMessage.MessageSource, _DATAEND1, _DATAEND2, [rfReplaceAll])+_DATAEND1, #13#10, stSendData);
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
begin
Result := True;
end;
end;
FMailMessage.FHeader.Text := sHeader;
end;
end;
sDests.Free;
end;
// Send string to specified recipients
function TSMTP2000.SendStringTo(const Msg, From, Dests: String): Boolean;
var
Loop: Integer;
AllOk: Boolean;
sDests: TStringList;
begin
Result := False;
if (not FSessionConnected) or (not FSocketTalk.ClientSocket.Active) then
begin
Exit;
end;
sDests := TStringList.Create;
sDests.Sorted := True;
sDests.Duplicates := dupIgnore;
sDests.CommaText := Dests;
if sDests.Count = 0 then
begin
Exception.CreateFmt(_E_NRTS, [Self.Name]);
Exit;
end;
FSocketTalk.Talk('MAIL FROM: <'+From+'>'#13#10, #13#10, stMail);
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
begin
AllOk := True;
for Loop := 0 to sDests.Count-1 do
begin
FSocketTalk.Talk('RCPT TO: <'+sDests[Loop]+'>'#13#10, #13#10, stRcpt);
FSocketTalk.WaitServer;
if not FSocketTalk.ServerResult then
begin
AllOk := False;
Break;
end;
end;
if AllOk then
begin
FSocketTalk.Talk('DATA'#13#10, #13#10, stData);
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
begin
FSocketTalk.PacketSize := FPacketSize;
FSocketTalk.Talk(StringReplace(Msg, _DATAEND1, _DATAEND2, [rfReplaceAll])+_DATAEND1, #13#10, stSendData);
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
begin
Result := True;
end;
end;
end;
end;
sDests.Free;
end;
// =============================================================================
function TPOP2000.GetUIDLS(List: TStrings):Boolean;
var
I,J:integer;
S,temp:String;
begin
Result :=False;
if (not FSessionConnected) or (not FSessionLogged) or (not FSocketTalk.ClientSocket.Active) then
begin
Exit;
end;
S:=SendCMD('UIDL'#13#10,stUIDL);
result:=FSocketTalk.ServerResult;
if result then
begin
S:= FSocketTalk.LastResponse;
I:=Pos(#13#10,S);
delete(S,1,I);
S:=trim(S);
while Trim(S)<>'' do
begin
I:=Pos(#13#10,S);
temp:=copy(S,1,I);
J:=pos(#32,temp);
if J=0 then Exit;
List.Add(copy(temp,J+1,Length(temp)-J));
delete(S,1,I);
S:=trim(S);
end;
//Result := Trim(Copy(Result, Pos(MsgNum+#32, Result)+Length(MsgNum)+1, Length(Result)));
end;
end;
function TPOP2000.SendCMD(CMD: string;state:TSessionState): string;
begin
Result:='';
if (not FSessionConnected) or (not FSessionLogged) or (not FSocketTalk.ClientSocket.Active) then
begin
Exit;
end;
FSocketTalk.Talk('UIDL'#13#10, '', state);
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
result:= FSocketTalk.LastResponse;
end;
function TPOP2000.RetrieveMessageByUIDL(UIDL: String): Boolean;
var
MailTxt: TStringList;
begin
Result := False;
FLastMessage := '';
if (not FSessionConnected) or (not FSessionLogged) or (not FSocketTalk.ClientSocket.Active) then
begin
Exit;
end;
//FSocketTalk.DataSize := FSessionMessageSize[Number-1];
FSocketTalk.Talk('UIDL'#32+UIDL+#13#10, _DATAEND1, stRetr);
FSocketTalk.WaitServer;
if FSocketTalk.ServerResult then
begin
MailTxt := TStringList.Create;
MailTxt.Text := FSocketTalk.LastResponse;
MailTxt.Delete(MailTxt.Count-1);
MailTxt.Delete(0);
FLastMessage := MailTxt.Text;
MailTxt.Free;
if Assigned(FMailMessage) then
begin
FMailMessage.Reset;
FMailMessage.Fill(PChar(FLastMessage), True);
end;
Result := True;
//if FDeleteOnRetrieve then
// DeleteMessage(Number);
end;
end;
end.