(************************************************************************
*    This File is Part of the AHM Triton Tools                          *
*    for Borland Delphi and C++ Builder.                                *
*************************************************************************
* Copyright © 1995-1999 Alexander H. Mehlhorn (AHM) and Tritontools.com *
* All Rights reserved.                                                  *
*                                                                       *
*    For more Information contact us at                                 *
*    E-Mail : support@tritontools.com                                   *
*    URL : http://www.tritontools.com                                   *
*                                                                       *
*    AHM is copyright by Alexander H. Mehlhorn                          *
*    All Parts of this Collection were developed,                       *
*    designed and implemented by AHM                                    *
*                                                                       *
*    Under no Circumstances may you distribute this file                *
*    in this or any other format. This File is supplied                 *
*    as Evaluation of Source only. No Delphi Components may be developed*
*    using extracts or subsets of this code without expressed permission*
*    by AHM.                                                            *
*                                                                       *
*************************************************************************)
unit AHMTIEmails;

interface

uses
  SysUtils,Windows,Classes,Scktcomp,AHMMailConst,AHMMailClass,AHMTMailAccount;

type
  TAHMPStep = 1..100;
  TAHMMailHost = Class;
  TAHMMessages = Class;
  TAHMAttachments = Class;
  TAHMMessage = Class;
  TAHMMailSessionState = (Authorization,Transaction);
  TAHMOnHostMessage= Procedure(Sender :TObject;Status,Msg :String) Of Object;
  TAHMOnInfoMessage= Procedure(Sender :TObject;Status,MsgText :String;IsError : Boolean) Of Object;
  TAHMOnConnectionState= Procedure(Sender :TObject;Const Server : String; Port : Integer) Of Object;
//  TAHMOnRead = Procedure(Sender :TObject;BytesRead :Integer) Of Object;
  TAHMOnCodingStart = Procedure(Sender :TObject;FileName :String;BytesCount :Longint) Of Object;
  TAHMMailProgress = Procedure(Sender :TObject;Percent :Word) Of Object;
  TAHMMailAction = Procedure(Sender :TObject;Index :Word) Of Object;
  TAHMAfterMsgAction = Procedure(sender :TObject;MailMessage : TAHMMessage) Of Object;
  TAHMAttachment = Class(TCollectionItem)
  private
    FFileName :String;
    FBodyEncoded :TStringlist;
    FBodyBin :TMemoryStream;
    FMimetype : String;
    FAHMMessage : TAHMMessage;
    FPhysFile : String;
  protected
    Function GetDisplayName :String;Override;
  Public
    Constructor Create(Collection :TCollection);Override;
    Destructor Destroy;Override;
    Procedure SaveToFile(FileName :String);
    Property Owner :TAHMMessage Read FAHMMessage;
    Property Mimetype :String Read FMimetype;
  published
    Property PhysFile : String read FPhysFile write FPhysFile stored True;
    Property FileName :String Read FFileName Write FFileName;
  end;
  TAHMAttachments = Class(TCollection)
  private
    FAHMMessage :TAHMMessage;
    Function GeTAHMAttachment(Index :Integer) :TAHMAttachment;
    Procedure SeTAHMAttachment(Index :Integer;Value :TAHMAttachment);
  protected
    Function GetOwner :TPersistent;Override;
    Function GetMimetype(Const FileName :String) :String;
  Public
    Constructor Create(AOwner :TAHMMessage);
    Function Add(Filename :String) :TAHMAttachment;
    Function Delete(Index :Integer) :Boolean;
    Property Items[Index :Integer] :TAHMAttachment
      Read GeTAHMAttachment Write SeTAHMAttachment;Default;
  end;
  TAHMMessage = Class(TCollectionItem)
  private
    FFrommail,FReplyTo,FSendTo,FSubject,FFromname :String;
    FMessageID,FInReplyTo,FDate :String;
    FMessage :TStrings;
    FHeader : String;
    FAHMMailHost :TAHMMailHost;
    FAtttypes :TStrings;
    FAHMAttachments :TAHMAttachments;
    FIndex: Integer;
    FAccount: TAHMMailAccount;
    Procedure SetAHMAttachments(Value :TAHMAttachments);
    Procedure SetMessage(Value :TStrings);
  Protected
    Function GetDisplayName :String;Override;
  Public
    Constructor Create(Collection :TCollection);Override;
    Destructor Destroy;Override;
    Property Owner :TAHMMailHost Read FAHMMailHost;
    Property Date :String Read FDate;
    Property MessageID :String Read FMessageID;
    Property InReplyTo :String Read FInReplyTo Write FInReplyTo;
    Property Account : TAHMMailAccount read FAccount;
    Property Index : Integer read FIndex;
    Property Header : String read FHeader;
  published
    Property FromMail :String Read FFromMail Write FFromMail;
    Property ReplyTo :String Read FReplyTo Write FReplyTo;
    Property SendTo :String Read FSendTo Write FSendTo;
    Property Subject :String Read FSubject Write FSubject;
    Property FromName :String Read FFromName Write FFromName;
    Property Message :TStrings Read FMessage Write SetMessage;
    Property Attachments :TAHMAttachments Read FAHMAttachments Write SeTAHMAttachments;
  end;
  TAHMMessages = Class(TCollection)
  private
    FAHMMailHost :TAHMMailHost;
    Function GetAHMMessage(Index :Integer) :TAHMMessage;
    Procedure SetAHMMessage(Index :Integer;Value :TAHMMessage);
  protected
    Function GetOwner :TPersistent;Override;
  Public
    Property Owner :TAHMMailHost Read FAHMMailHost;
    Constructor Create(AOwner :TAHMMailHost);
    Function Add :TAHMMessage;
    Function Delete(Index :Integer) :Boolean;
    Property Items[Index :Integer] :TAHMMessage Read GetAHMMessage Write SetAHMMessage;Default;
  end;
  TAHMMailHost = Class(TAHMMailsComponent)
  private
    FConnected : Boolean;
    FOnConnect : TAHMOnConnectionState;
    FBusy : Boolean;
    FCancel : Boolean;
    FSocketStream :TWinSocketStream;
    FSocket :TClientSocket;
    FOnExecute :TNotifyEvent;
    FAHMMessages :TAHMMessages;
    FOnServerMessage : TAHMOnHostMessage;
    FHostStatus,FHostMsg : String;
    FAccountInfo: TAHMAccountHolder;
    FCurrentAccount : TAHMMailAccount;
    FAfterExecute: TNotifyevent;
    FBeforeExecute: TNotifyEvent;
    FOnServerMsg: TAHMOnInfoMessage;
    FOnError: TAHMOnInfoMessage;
    FOnDisconnect: TAHMOnConnectionState;
    Procedure SetAHMMessages(Value :TAHMMessages);
    Procedure SetAccountInfo(const Value: TAHMAccountHolder);
    Procedure DoConnect(Sender :TObject;Socket :TCustomWinSocket);
    Procedure DoDisconnect(Sender :TObject;Socket :TCustomWinSocket);
  protected
    procedure Notification(AComponent: TComponent;Operation: TOperation); override;
    procedure HandleError(ErrorEvent :TErrorEvent);
    procedure HandleErrorAndExit(Sender :TObject;Socket :TCustomWinSocket;ErrorEvent :TErrorEvent;Var ErrorCode :Integer);
    procedure Connect(Server : String;Port,TimeOut : Integer); virtual;
    procedure SendSocketText(const SocketText: String); virtual;
    Function GetSocketText : String; virtual;
    Procedure Disconnect; virtual;
    Procedure HandleServerResponse(Status,MsgText : String;IsError : Boolean);
  public
    Constructor Create(AOwner :TComponent);Override;
    Destructor Destroy;Override;
    Function Execute :Boolean;Override;
    Property CurrentAccount : TAHMMailAccount read FCurrentAccount;
    Property Connected : Boolean read FConnected;
    Property Cancelled : Boolean read FCancel;
  published
    Property OnServerMessage : TAHMOnHostMessage read FOnServerMessage write FOnServerMessage;
    Property Messages :TAHMMessages Read FAHMMessages Write SetAHMMessages;
    Property OnExecute :TNotifyevent Read FOnExecute Write FOnExecute;
    Property AccountInfo : TAHMAccountHolder read FAccountInfo write SetAccountInfo;
    Property BeforeExecute : TNotifyEvent read FBeforeExecute write FBeforeExecute;
    Property AfterExecute : TNotifyevent read FAfterExecute write FAfterExecute;
    Property OnServerResponse : TAHMOnInfoMessage read FOnServerMsg write FOnServerMsg;
    Property OnError : TAHMOnInfoMessage read FOnError write FOnError;
    Property OnConnect : TAHMOnConnectionState read FOnConnect write FOnConnect;
    Property OnDisconnect : TAHMOnConnectionState read FOnDisconnect write FOnDisconnect;
  end;
  TAHMSMTPMail = Class(TAHMMailHost)
  private
    FSignature :TStrings;
    FSMTPError :Boolean;
    FSendProgress :Word;
    FEncodeProgress :Word;
    FOnBeforeSend :TNotifyEvent;
    FOnAfterSend :TAHMAfterMsgAction;
    FOnSuccessSend :TNotifyEvent;
    FOnSendProgress :TAHMMailProgress;
    FOnEncodeStart :TAHMOnCodingStart;
    FOnEncodeProgress :TAHMMailProgress;
    FOnEncodeend :TNotifyEvent;
    Procedure SetSignature(Value :TStrings);
    Procedure DoEncodeStart(FileName :String;Size :longint);
    Procedure DoEncodeProgress(Percent :Word);
    Procedure DoEncodeend;
    Procedure DoSendProgress(Percent :Word);
    Procedure DoOnBeforeSend;
    Function CreateUIN :String;
    Function InitializeMessage(Var VMessage :TAHMMessage) :TStringlist;
    Function CreateBounds :String;
  protected
    Procedure Base64Encode(Var VAttachment :TAHMAttachment);
    Procedure Connect(Server: String; Port, TimeOut: Integer); override;
    Function GetSocketText :String; override;
  Public
    Constructor Create(AOwner :TComponent);Override;
    Destructor Destroy;Override;
    Function Execute :Boolean;Override;
    Function SendMessage(VMessage :TAHMMessage) :Boolean;
    Property Connected :Boolean Read FConnected;
    Property SMTPError :Boolean Read FSMTPError;
  published
    Property Signature :TStrings Read FSignature Write SetSignature;
    Property OnBeforeSend :TNotifyEvent Read FOnBeforeSend Write FOnBeforeSend;
    Property OnAfterSend :TAHMAfterMsgAction Read FOnAfterSend Write FOnAfterSend;
    Property OnSuccessSend :TNotifyEvent Read FOnSuccessSend Write FOnSuccessSend;
    Property OnEncodeStart :TAHMOnCodingStart Read FOnEncodeStart Write FOnEncodeStart;
    Property OnEncodeProgress :TAHMMailProgress Read FOnEncodeProgress Write FOnEncodeProgress;
    Property OnEncodeend :TNotifyEvent Read FOnEncodeend Write FOnEncodeend;
    Property OnSendProgress :TAHMMailProgress Read FOnSendProgress Write FOnSendProgress;
  end;
  TAHMPOPMail = Class(TAHMMailHost)
  private
    FSessionState :TAHMMailSessionState;
    FExistingIDS : TStrings;
    FPOPError :Boolean;
    FPOPErrorString :String;
    FReceivingVMessage :Boolean;
    FSize :longint;
    FStep :Word;
    FDecodeProgress :Word;
    FRetrieveProgress :Word;
    FDeletedItems :TStrings;
    FVMessagesCount :Word;
    FOnDecodeStart :TAHMOnCodingStart;
    FOnDecodeProgress :TAHMMailProgress;
    FOnDecodeEnd :TNotifyEvent;
    FOnBeforeRetrieve :TAHMMailAction;
    FOnAfterRetrieve :TAHMAfterMsgAction;
    FOnRetrieveProgress :TAHMMailProgress;
    FOnDelete :TAHMMailAction;
    Function FindInHeaders(Const que :String;Const StrList :TStringList;var Line :Integer) :Boolean;
    Function FindInStringList(Const que :String;Const StrList :TStringlist;var Line,position :Integer) :Boolean;
    Function FindInStringListCS(Const que :String;Const StrList :TStringlist;var Line,position :Integer) :Boolean;
    Function GetUUAttachments(Const StrList :TStringlist;Var Line :Integer;var FileName :String) :Boolean;
  protected
    Procedure Base64Decode(Var VAttachment :TAHMAttachment);
    Procedure UUDecode(Var VAttachment :TAHMAttachment);
    Procedure Connect(Server: String; Port, TimeOut: Integer); override;
    Function GetSocketText :String; override;
    Function Login :Boolean;
    Function Init :Word;
    Procedure DeleteMessage(Index :Word);
    Function RetrieveMessages : Integer;
    Procedure RetrieveMessage(Index : Word;GetHeaderOnly : Boolean);
  Public
    Constructor Create(AOwner :TComponent);Override;
    Destructor Destroy; Override;
    Property DeletedItems : TStrings Read FDeletedItems Write FDeletedItems;
    Function DownloadMessage(Index : Integer) :Boolean;
    Function EraseMessage(Index : Integer) :Boolean;
    Function Execute : Boolean;Override;
    Property POPError : Boolean Read FPOPError;
    Property ErrorString : String Read FPOPErrorString;
    Property VMessagesCount :Word Read FVMessagesCount;
    Property SessionState : TAHMMailSessionState Read FSessionState;
    Property MessageIds : TStrings read FExistingIDS;
  published
    Property Messages Stored False;
    Property OnDecodeStart : TAHMOnCodingStart Read FOnDecodeStart Write FOnDecodeStart;
    Property OnDecodeProgress : TAHMMailProgress Read FOnDecodeProgress Write FOnDecodeProgress;
    Property OnDecodeEnd : TNotifyEvent Read FOnDecodeEnd Write FOnDecodeEnd;
    Property BeforeRetrieve : TAHMMailAction Read FOnBeforeRetrieve Write FOnBeforeRetrieve;
    Property AfterRetrieve : TAHMAfterMsgAction Read FOnAfterRetrieve Write FOnAfterRetrieve;
    Property OnRetrieveProgress :TAHMMailProgress Read FOnRetrieveProgress Write FOnRetrieveProgress;
    Property OnDelete : TAHMMailAction Read FOnDelete Write FOnDelete;
  end;
Const
  crlf = #13#10;

Implementation

Uses Forms,Registry,Dialogs;

Function RandomText(SLength :Integer) :String;
begin
  randomize;result := '';
  While Length(result) < SLength Do result := result + Chr(97 + random(25));
end;

Constructor TAHMSMTPMail.create(AOwner :TComponent);
begin
  Inherited create(AOwner);
  FSignature := TStringlist.Create;
  FBusy := False;
end;

Destructor TAHMSMTPMail.Destroy;
begin
  FSignature.Free;
  Inherited Destroy;
end;

Function TAHMSMTPMail.Execute :Boolean;
Var Accounts,I :Integer;
begin
  result:=False;
  if assigned(FBeforeExecute) then FBeforeExecute(Self);
  if (AccountInfo=nil) then
  begin
    HandleServerResponse(AHMRcMailErr,AHMRcMailNoAccounts,true);
    if assigned(FAfterExecute) then FAfterExecute(Self);
    exit;                      
  end;
  for Accounts:=0 to AccountInfo.Accounts.Count-1 do
  if AccountInfo.Accounts[Accounts].Default then
  begin
  if (AccountInfo.Accounts[Accounts].SMTPServer='') then
  begin
    HandleServerResponse(AHMRcMailErr,AHMRcMailNoAccounts,true);
    if assigned(FAfterExecute) then FAfterExecute(Self);
    exit;
  end;
    FCurrentAccount:=AccountInfo.Accounts[Accounts];
    result := Inherited Execute;
    try
      If Not (FBusy) Then
      begin
        FBusy := True;
        FSocket := TClientSocket.create(Nil);
        FSocket.Clienttype := ctBlocking;
        FSocket.OnConnect := DoConnect;
        FSocket.OnDisconnect := DoDisconnect;
        FSocket.OnError := HandleErrorAndExit;
        with FCurrentAccount do Connect(SMTPServer,SMTPPort,Timeout);
        For i := 0 To Messages.count - 1 Do Sendmessage(messages[I]);
      end;
      Disconnect;
      FBusy := False;
      if FSocket<>nil then FSocket.Free;
    except
      Application.HandleException(self);
      result := false;
      if FSocket<>nil then FSocket.Free;
    end;
    break;
  end;
  if assigned(FAfterExecute) then FAfterExecute(Self);
end;

Procedure TAHMSMTPMail.Connect(Server: String; Port, TimeOut: Integer);
begin
  inherited Connect(Server,Port,TimeOut);
  GetSocketText;
  while (FHostStatus <> '220') And (FHostStatus <> '421') Do
  begin
    GetSocketText;
    Application.ProcessMessages;
    If Not FConnected Then exit;
  end;
  FSMTPError := FHostStatus <> '220';
  If FSMTPError Then
  begin
    HandleError(eeConnect);
    exit;
  end;
  SendSocketText('HELO ' + FSocket.Socket.LocalHost + crlf);
  GetSocketText;
  FSMTPError := FHostStatus <> '250';
  If FSMTPError Then HandleError(eeConnect);
  FCancel := False;
end;

Procedure TAHMMailHost.DoConnect(Sender :TObject;Socket :TCustomWinSocket);
begin
  FConnected := true;
  If assigned(FOnConnect) Then FOnConnect(Sender,FSocket.Host,FSocket.Port);
end;

Procedure TAHMMailHost.Disconnect;
begin
  If FConnected Then
  begin
    If FCancel Then
    begin
      if FSocket.Active then FSocket.Close;
      if FSocketStream<>nil then FSocketStream.Free;
      FConnected := false;
      FBusy:=False;
    end else
    begin
      try
        if (FSocket<>nil) and (FSocketStream<>nil) then
        if FSocket.Active then
        begin
          SendSocketText('QUIT' + crlf);
          GetSocketText;
        end;
        if (Self is TAHMSMTPMail) and (FHostStatus <> '221') then HandleServerResponse(FHostStatus,FHostMsg,True);
      finally
        if FSocket.Active then FSocket.close;
        if FSocketStream<>nil then FSocketStream.Free;
        FConnected := false;
        FBusy:=False;
      end
    end;
  end;
end;

Function TAHMSMTPMail.SendMessage(VMessage :TAHMMessage) :Boolean;
Var
  I :Integer;
  RecP,TOs :String;
  StrListVMessage :TStringList;
  step :Word;
  success :Boolean;
begin
  result := false;
  Success := True;
  If Not FConnected Then Exception.create(AHMRcMailNotConnected);
  If VMessage.FromMail = '' Then Exception.create(AHMRcMailNoFromName);
  If VMessage.SendTo = '' Then Exception.create(AHMRcMailNoSendTo);
  VMessage.FDate := FormatDateTime(AccountInfo.DateTimeFormat,Now);
  StrListVMessage := InitializeMessage(VMessage);
  If FCancel Then exit;
  DoOnBeforeSend;
  SendSocketText('MAIL FROM:' + '<' + VMessage.FromMail + '>' + crlf);
  GetSocketText;
  FSMTPError := FHostStatus <> '250';
  If FSMTPError Then
  begin
    HandleError(eeGeneral);
    exit;
    Success := false;
  end;
  RecP:='';
  TOs := trim(VMessage.SendTo);
  While pos(';',TOs) > 0 Do
  begin
    RecP :=RecP+'<'+trim(copy(TOs,1,pos(';',TOs)-1))+'>,';
    delete(TOs,1,pos(';',TOs));
  end;
  if TOs<>';' then RecP:=RecP+'<'+TOs+'>' else Delete(RecP,Length(RecP),1);
  TOs:=RecP;
  repeat
    if Pos(',',TOs)>0 then
    begin
      RecP:=Copy(TOs,1,Pos(',',TOs)-1);
      Delete(TOs,1,Pos(',',TOs));
    end else
    if pos('@',TOs)>0 then
    begin
      RecP:=TOs;
      TOs:='';
    end else TOs:='';
    SendSocketText('RCPT TO:' + RecP + crlf);
    GetSocketText;
    FSMTPError := FHostStatus <> '250';
    If FSMTPError Then
    begin
      HandleError(eeGeneral);
      exit;
      Success := false;
    end;
  until TOs='';
  SendSocketText('DATA' + crlf);
  GetSocketText;
  FSMTPError := (FHostStatus <> '354');
  If FSMTPError Then
  begin
    HandleError(eeGeneral);
    exit;
    Success := false;
  end;
  step := FCurrentAccount.ProgressStep;
  For i := 0 To StrListVMessage.Count - 1 Do
  begin
    SendSocketText(StrListVMessage[i] + crlf);
    FSendProgress := round(100 * i / StrListVMessage.Count);
    If (FSendProgress >= step) Then
    begin
      DoSendProgress(FSendProgress);
      inc(step,FCurrentAccount.ProgressStep);
    end;
    Application.ProcessMessages;
    If FCancel Then exit;
    Sleep(40);
  end;
  SendSocketText(crlf + '.' + crlf);
  GetSocketText;
  If FSendProgress < 100 Then DoSendProgress(100);
  FSMTPError :=FHostStatus <> '250';
  If FSMTPError Then
  begin
    HandleError(eeGeneral);
    exit;
    Success := false;
  end;
  If success And assigned(FOnSuccessSend) Then FOnSuccessSend(self);
  result := true;
  If assigned(FOnAfterSend) Then FOnAfterSend(self,VMessage);
end;


Function TAHMSMTPMail.InitializeMessage(Var VMessage :TAHMMessage) :TStringList;
Var
  I :Integer;
  Boundary,UsrName :String;
  Body,Headers :TStringList;
  AttFile :TAHMAttachment;
  RecP,SendToP : String;
begin
  result := Nil;
  Headers := TStringList.Create;
  Body := TStringList.Create;
  Body.Text := VMessage.Message.Text;
  Body.Add(crlf);
  Body.AddStrings(FSignature);
  i := 0;
  While (i < Body.Count) Do
  begin
    If pos('.',Body[i]) = 1 Then Body[i] := '.' + Body[i];
    inc(i);
  end;
  UsrName := VMessage.FromName;
  Headers.Add('Message-Id: ' + CreateUIN);
  If VMessage.InReplyTo <> '' Then Headers.Add('In-Reply-To: ' + VMessage.InReplyTo);
  Headers.Add('Date: ' + VMessage.Date);
  If UsrName <> '' Then
  begin
    If (pos('@',VMessage.FromMail) = 0) Then
      Headers.Add('From: ' + '"' + UsrName + '" <' + VMessage.FromMail + '@' + FCurrentAccount.SMTPServer + '>')
    Else Headers.Add('From: ' + '"' + UsrName + '" <' + VMessage.FromMail + '>');
  end Else Headers.Add('From: ' + VMessage.FromMail);
  If VMessage.ReplyTo <> '' Then Headers.Add('Reply-To: ' + VMessage.ReplyTo);
  Headers.Add('X-Mailer: ' + Application.Title + ' - [' + self.classname + ']');
  SendToP :=VMessage.SendTo;
  while pos(';',SendToP)>0 do
  begin
    RecP:='<'+Copy(SendToP,1,Pos(';',SendToP)-1)+'>,';
    Delete(SendToP,1,Pos(';',SendToP));
  end;
  if SendToP<>';' then RecP:=RecP+'<'+SendToP+'>' else Delete(RecP,Length(RecP),1);
  Headers.Add('TO: '+RecP);
  Headers.Add('Subject: ' + VMessage.Subject);
  Headers.Add('MIME-Version: 1.0');
  If VMessage.Attachments.count = 0 Then
  begin
    Headers.Add('Content-type: Text/Plain; charset=ISO-8859-1');
    Headers.Add('Content-Transfer-Encoding: 8bit');
  end;
  If VMessage.Attachments.count > 0 Then
  begin
    boundary := CreateBounds;
    Headers.Add('Content-type: multipart/mixed; boundary="' + boundary + '"');
    boundary := '--' + boundary;
    Body.Insert(0,boundary);
    Body.Insert(1, 'Content-type: Text/Plain; charset: ISO-8859-1');
    Body.Insert(2, 'Content-Transfer-Encoding: 8bit');
    Body.Insert(3, '');
    For i := 0 To VMessage.Attachments.count - 1 Do
    begin
      AttFile := VMessage.Attachments[i];
      Body.Add(boundary);
      Body.Add('Content-type: ' + AttFile.MIMEtype + '; name="' + AttFile.FileName + '"');
      Body.Add('Content-Transfer-Encoding: base64');
      Body.Add('Content-Disposition: inLine; filename="' + VMessage.Attachments[i].fileName + '"');
      Body.Add('');
      Base64Encode(AttFile);
      If FCancel Then exit;
      Body.AddStrings(AttFile.FBodyEncoded);
    end;
    Body.Add('');
    Body.Add(boundary + '--');
    Body.Add('');
  end;
  Application.ProcessMessages;
  If FCancel Then exit;
  result := TStringList.Create;
  result.AddStrings(Headers);
  result.Add('');
  result.AddStrings(Body);
  Headers.Free;
  Body.Free;
end;

Function TAHMSMTPMail.CreateUIN :String;
begin
  result := '<ahmtt2000.' + FormatDateTime('hhnn.ddmmyyyy',Now) + RandomText(8) +
    '@' + FSocket.Socket.LocalHost + '>';
end;

Procedure TAHMSMTPMail.Base64Encode(Var VAttachment :TAHMAttachment);
Const
  _Code64 :String[64] =
    ('ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/');
Var
  i,BytesCoded :longint;
  b :Array[0..2279] Of byte;
  j,k,l,m,quads,step :Integer;
  stream :String[76];
  TextCoded :TStringList;
  TextBin :TFileStream;
begin
  TextBin := TFileStream.Create(VAttachment.PhysFile,fmOpenRead Or fmShareDenyNone);
  DoEncodeStart(VAttachment.PhysFile,TextBin.Size);
  TextCoded := TStringList.Create;
  stream := '';
  step := FCurrentAccount.ProgressStep;
  BytesCoded := 0;
  quads := 0;
  j := TextBin.Size Div 2280;
  For i := 1 To j Do
  begin
    Application.ProcessMessages;
    If FCancel Then exit;
    TextBin.Read(b,2280);
    For m := 0 To 39 Do
    begin
      For k := 0 To 18 Do
      begin
        l := 57 * m + 3 * k;
        stream[quads + 1] := _Code64[(b[l] Div 4) + 1];
        stream[quads + 2] := _Code64[(b[l] Mod 4) * 16 + (b[l + 1] Div 16) + 1];
        stream[quads + 3] := _Code64[(b[l + 1] Mod 16) * 4 + (b[l + 2] Div 64) + 1];
        stream[quads + 4] := _Code64[b[l + 2] Mod 64 + 1];
        Inc(quads,4);
        If quads = 76 Then
        begin
          stream[0] := #76;
          TextCoded.Add(stream);
          inc(BytesCoded,57);
          FEncodeProgress := round(100 * BytesCoded / TextBin.Size);
          If (FEncodeProgress >= step) Then
          begin
            DoEncodeProgress(FEncodeProgress);
            inc(step,FCurrentAccount.ProgressStep);
          end;
          Application.ProcessMessages;
          quads := 0;
        end;
      end;
    end;
  end;
  j := (TextBin.Size Mod 2280) Div 3;
  For i := 1 To j Do
  begin
    Application.ProcessMessages;
    If FCancel Then exit;
    TextBin.Read(b,3);
    stream[quads + 1] := _Code64[(b[0] Div 4) + 1];
    stream[quads + 2] := _Code64[(b[0] Mod 4) * 16 + (b[1] Div 16) + 1];
    stream[quads + 3] := _Code64[(b[1] Mod 16) * 4 + (b[2] Div 64) + 1];
    stream[quads + 4] := _Code64[b[2] Mod 64 + 1];
    Inc(quads,4);
    If quads = 76 Then
    begin
      stream[0] := #76;
      TextCoded.Add(stream);
      quads := 0;
    end;
  end;
  If (TextBin.Size Mod 3) = 2 Then
  begin
    TextBin.Read(b,2);
    stream[quads + 1] := _Code64[(b[0] Div 4) + 1];
    stream[quads + 2] := _Code64[(b[0] Mod 4) * 16 + (b[1] Div 16) + 1];
    stream[quads + 3] := _Code64[(b[1] Mod 16) * 4 + 1];
    stream[quads + 4] := '=';
    Inc(quads,4);
  end;
  If (TextBin.Size Mod 3) = 1 Then
  begin
    TextBin.Read(b,1);
    stream[quads + 1] := _Code64[(b[0] Div 4) + 1];
    stream[quads + 2] := _Code64[(b[0] Mod 4) * 16 + 1];
    stream[quads + 3] := '=';
    stream[quads + 4] := '=';
    Inc(quads,4);
  end;
  TextBin.Free;
  stream[0] := Chr(quads);
  If quads > 0 Then TextCoded.Add(stream);
  If FEncodeProgress < 100 Then DoEncodeProgress(100);
  Application.ProcessMessages;
  If FCancel Then exit;
  VAttachment.FBodyEncoded := TextCoded;
  DoEncodeend;
end;

Function TAHMSMTPMail.CreateBounds :String;
begin
  result := '---AHMMAIL' + RandomText(12);
end;

Procedure TAHMSMTPMail.SetSignature(Value :TStrings);
begin
  FSignature.Assign(Value);
end;

Procedure TAHMMailHost.DoDisconnect(Sender :TObject;Socket :TCustomWinSocket);
begin
  FConnected := False;
  If assigned(FOnDisconnect) Then FOnDisconnect(Sender,FSocket.Host,FSocket.Port)
end;

Function TAHMSMTPMail.GetSocketText :String;
Var
  s :String;
  i,x :Integer;
  buff :Array[1..1024] Of char;
begin
  if (FSocket<>nil) then
  if (FSocket.Active) and (FSocketStream<>nil) then
  begin
  Repeat
    While Not FSocketStream.WaitForData(FCurrentAccount.TimeOut*100) Do Application.ProcessMessages;
    x := FSocketStream.read(buff,1024);
    s := copy(buff,1,x);
    i := pos(crlf,s);
    If (i > 0) And (length(s) > i + 2) Then s := copy(s,i + 2,64);
    FHostStatus:=UpperCase(Trim(Copy(s,1,3)));
    FHostMsg:=Trim(Copy(s,4,64));
    if Assigned(FOnServerMessage) then FOnServerMessage(Self,FHostStatus,FHostMsg);
    result := s;
    Application.ProcessMessages;
    If s = '' Then s := '----';
  until s[4] = ' ';
  end;
end;

Procedure TAHMSMTPMail.DoOnBeforeSend;
begin
  If assigned(FOnBeforeSend) Then FOnBeforeSend(self);
end;

Procedure TAHMSMTPMail.DoEncodeStart(FileName :String;Size :longint);
begin
  If assigned(FOnEncodeStart) Then FOnEncodeStart(self,FileName,Size);
end;

Procedure TAHMSMTPMail.DoEncodeProgress(Percent :Word);
begin
  If assigned(FOnEncodeProgress) Then FOnEncodeProgress(self,Percent);
end;

Procedure TAHMSMTPMail.DoEncodeend;
begin
  If assigned(FOnEncodeend) Then FOnEncodeend(self);
end;

Procedure TAHMSMTPMail.DoSendProgress(Percent :Word);
begin
  If assigned(FOnSendProgress) Then FOnSendProgress(self,Percent);
end;

Constructor TAHMAttachment.Create(Collection :TCollection);
begin
  Inherited Create(Collection);
  FAHMMessage := (((Collection As TAHMAttachments).GetOwner) As TAHMMessage);
  FBodyBin := TMemoryStream.Create;
  FBodyEncoded := TStringList.Create;
end;

Destructor TAHMAttachment.Destroy;
begin
  FBodyBin.Free;
  FBodyEncoded.Free;
  Inherited Destroy;
end;

Procedure TAHMAttachment.SaveToFile(Filename :String);
begin
  If FBodyBin = Nil Then Exception.create(AHMRcMailInvalidOp)
  Else
  begin
    Try
      FBodyBin.SaveToFile(Filename);
    Except
      Application.HandleException(self);
    end;
  end;
end;

Function TAHMAttachment.GetDisplayName :String;
begin
  Result := AHMRcMailAttachment;
end;

Function TAHMAttachments.GetOwner :TPersistent;
begin
  Result := FAHMMessage;
end;

Constructor TAHMAttachments.Create(AOwner :TAHMMessage);
begin
  Inherited Create(TAHMAttachment);
  FAHMMessage := AOwner;
end;

Function TAHMAttachments.Add(Filename :String) :TAHMAttachment;
Var
  XAttachment :TAHMAttachment;
begin
  XAttachment := TAHMAttachment(Inherited Add);
  XAttachment.FFileName := ExtractFileName(Filename);
  XAttachment.PhysFile := Filename;
  XAttachment.FMimetype := GetMimetype(Filename);
  Result := XAttachment;
end;

Function TAHMAttachments.GetMimetype(Const FileName :String) :String;
Var
  Key :String;
begin
  Result := '';
  With TRegistry.Create Do
  Try
    RootKey := HKEY_CLASSES_ROOT;
    Key := ExtractFileExt(FileName);
    If KeyExists(Key) Then
    begin
      OpenKey(Key,false);
      Result := ReadString('Content type');
      CloseKey;
    end;
  Finally
    If Result = '' Then
      Result := 'application/octet-stream';
    free;
  end;
end;


Function TAHMAttachments.Delete(Index :Integer) :Boolean;
begin
  result := true;
  Try
    Items[Index].free;
  Except
    result := false;
    Application.handleexception(self);
  end;
end;

Function TAHMAttachments.GeTAHMAttachment(Index :Integer) :TAHMAttachment;
begin
  Result := TAHMAttachment(Inherited GetItem(Index));
end;

Procedure TAHMAttachments.SeTAHMAttachment(Index :Integer;Value :TAHMAttachment);
begin
  Inherited SetItem(Index,Value);
end;

Constructor TAHMMessage.Create(Collection :TCollection);
begin
  Inherited Create(Collection);
  FMessage := TStringList.Create;
  FAHMAttachments := TAHMAttachments.Create(self);
  FAtttypes := TStringList.Create;
  FAHMMailHost := (((Collection As TAHMMessages).GetOwner) As TAHMMailHost);
end;

Procedure TAHMMessage.SetAHMAttachments(Value :TAHMAttachments);
begin
  FAHMAttachments.Assign(Value);
end;

Destructor TAHMMessage.Destroy;
begin
  FMessage.Free;
  FAHMAttachments.Free;
  FAtttypes.Free;
  Inherited Destroy;
end;

Function TAHMMessage.GetDisplayName :String;
begin
  If ((Owner As TComponent) Is TAHMSMTPMail) Then Result := AHMRcMailOutgoingMsg
  else Result := AHMRcMailIncomingMsg;
end;

Function TAHMMessages.GetOwner :TPersistent;
begin
  Result := FAHMMailHost;
end;

Procedure TAHMMessage.SetMessage(Value :TStrings);
begin
  FMessage.Assign(Value);
end;

Constructor TAHMMessages.Create(AOwner :TAHMMailHost);
begin
  Inherited Create(TAHMMessage);
  FAHMMailHost := AOwner;
end;

Function TAHMMessages.Add :TAHMMessage;
begin
  Result := TAHMMessage(Inherited Add);
end;

Function TAHMMessages.Delete(Index :Integer) :Boolean;
begin
  if (FAHMMailHost is TAHMPopMail) then
  TAHMPopMail(FAHMMailHost).FExistingIDS.Delete(TAHMPopMail(FAHMMailHost).FExistingIDS.IndexOf(Items[Index].MessageID));
  result := true;
  Try
    items[Index].free;
  Except
    Application.HandleException(self);
    result := false;
  end;
end;

Function TAHMMessages.GetAHMMessage(Index :Integer) :TAHMMessage;
begin
  Result := TAHMMessage(Inherited GetItem(Index));
end;

Procedure TAHMMessages.SetAHMMessage(Index :Integer;Value :TAHMMessage);
begin
  Inherited SetItem(Index,Value);
end;

Constructor TAHMMailHost.Create(AOwner :TComponent);
begin
  Inherited create(AOwner);
  FAHMMessages := TAHMMessages.Create(self);
end;

Destructor TAHMMailHost.Destroy;
begin
  FAHMMessages.Free;
  Inherited Destroy;
end;

Function TAHMMailHost.Execute :Boolean;
begin
  result := true;
  If assigned(FOnExecute) Then FOnExecute(Self);
end;

procedure TAHMMailHost.HandleError(ErrorEvent :TErrorEvent);
Var X : Integer;
begin
  X:=0;
  HandleErrorAndExit(self,FSocket.Socket,ErrorEvent,X);
end;

procedure TAHMMailHost.HandleServerResponse(Status, MsgText: String;IsError : Boolean);
begin
  if IsError or (Uppercase(Status)=AHMRcMailErr) then
  if assigned(FOnError) then FOnError(Self,Status,MsgText,IsError);
  if assigned(FOnServerMsg) then FOnServerMsg(Self,Status,MsgText,IsError);
end;

procedure TAHMMailHost.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FAccountInfo) then SetAccountInfo(nil);
end;

procedure TAHMMailHost.SetAccountInfo(const Value: TAHMAccountHolder);
begin
  FAccountInfo := Value;
end;

Procedure TAHMMailHost.SetAHMMessages(Value :TAHMMessages);
begin
  FAHMMessages.Assign(Value);
end;

Constructor TAHMPopMail.Create(AOwner :TComponent);
begin
  Inherited create(AOwner);
  FExistingIDS := TStringlist.Create;
  FDeletedItems := TStringlist.Create;
  FConnected := false;
  FBusy := False;
  FReceivingVMessage := false;
end;

Destructor TAHMPopMail.Destroy;
begin
  FDeletedItems.Free;
  FExistingIDS.Free;
  Inherited Destroy;
end;

Function TAHMPopMail.Execute :Boolean;
Var Accnts : Integer;
begin
  result:=False;
  if Assigned(FBeforeExecute) then FBeforeExecute(Self);
  if AccountInfo=nil then
  begin
    if Assigned(FAfterExecute) then FAfterExecute(Self);
    HandleServerResponse(AHMRcMailErr,AHMRcMailNoAccounts,true);
    exit;
  end;
  for Accnts:=0 to AccountInfo.Accounts.Count-1 do
  begin
    FCurrentAccount:=AccountInfo.Accounts[Accnts];
    result := Inherited Execute;
    try
      if not(FBusy) Then
      begin
        FBusy := True;
        FSocket := TClientSocket.create(Nil);
        FSocket.Clienttype := ctBlocking;
        FSocket.OnConnect := DoConnect;
        FSocket.OnDisconnect := DoDisconnect;
        FSocket.OnError := HandleErrorAndExit;
        with FCurrentAccount do Connect(Pop3Server,Pop3Port,Timeout);
        if Login then
        begin
          Init;
          RetrieveMessages;
        end;
      end;
      Disconnect;
      FBusy := False;
      if FSocket<>nil then FSocket.Free;
    except
      Application.HandleException(self);
      if FSocket<>nil then FSocket.Free;
      result := false;
    end;
  end;
end;

Function TAHMPopMail.DownloadMessage(Index : Integer) :Boolean;
begin
  result:=False;
  if Index>Messages.Count-1 then exit;
  FCurrentAccount:=Messages[Index].Account;
  try
    if not(FBusy) Then
    begin
      FBusy := True;
      FSocket := TClientSocket.create(Nil);
      FSocket.Clienttype := ctBlocking;
      FSocket.OnConnect := DoConnect;
      FSocket.OnDisconnect := DoDisconnect;
      FSocket.OnError := HandleErrorAndExit;
      with FCurrentAccount do Connect(Pop3Server,Pop3Port,Timeout);
      if Login then
      begin
        Init;
        RetrieveMessage(Messages[Index].FIndex,False);
        Messages.Delete(Index);
      end;
    end;
    Disconnect;
  except
    Application.HandleException(self);
    result := false;
  end;
  FBusy:=False;
  if FSocket<>nil then FSocket.Free;
end;

Function TAHMPopMail.EraseMessage(Index : Integer) :Boolean;
Var I,XIndex : Integer;
begin
  result:=False;
  FCurrentAccount:=Messages[Index].Account;
  try
    if not(FBusy) Then
    begin
      FBusy := True;
      FSocket := TClientSocket.create(Nil);
      FSocket.Clienttype := ctBlocking;
      FSocket.OnConnect := DoConnect;
      FSocket.OnDisconnect := DoDisconnect;
      FSocket.OnError := HandleErrorAndExit;
      with FCurrentAccount do Connect(Pop3Server,Pop3Port,Timeout);
      if Login then
      begin
        Init;
        DeleteMessage(Messages[Index].FIndex);
        XIndex:=Messages[Index].FIndex;
        Messages.Delete(Index);
        for I:=0 to Messages.Count-1 do
          if (Messages[I].FIndex>XIndex) and (Messages[I].Account=CurrentAccount) then
          Messages[I].FIndex:=Messages[I].FIndex-1;
      end;
    end;
    Disconnect;
  except
    Application.HandleException(self);
    result := false;
  end;
  FBusy:=False;
  if FSocket<>nil then FSocket.Free;
end;

Procedure TAHMPopMail.Connect(Server: String; Port, TimeOut: Integer);
begin
  inherited Connect(Server,Port,Timeout);
  GetSocketText;
  FSessionState := Authorization;
  FCancel := False;
  If FPOPError then HandleError(eeConnect);
end;

Function TAHMPopMail.Login :Boolean;
begin
  result := false;
  If Not FConnected Then Exception.create(AHMRcMailNoUserConn);
  SendSocketText('USER ' + FCurrentAccount.Username + crlf);
  GetSocketText;
  If FPOPError Then
  begin
    HandleError(eeGeneral);
    exit;
  end;
  SendSocketText('PASS ' + FCurrentAccount.Password + crlf);
  GetSocketText;
  If FPOPError Then
  begin
    HandleError(eeGeneral);
    exit;
  end;
  result := true;
  FSessionState := Transaction;
end;

Function TAHMPopMail.Init :Word;
Var
  i :Integer;
begin
  result := 0;
  SendSocketText('STAT' + crlf);
  GetSocketText;
  If FPOPError Then
  begin
    HandleError(eeGeneral);
    exit;
  end;
  i := pos(' ',FHostMsg);
  try
    FVMessagesCount := StrToInt(copy(FHostMsg,1,i - 1));
  except
    FVMessagesCount := 0;
  end;
  result := FVMessagesCount;
end;

Procedure TAHMPopMail.DeleteMessage(Index :Word);
begin
  If Not FConnected Then Exception.create(AHMRcMailNotConn);
  Application.ProcessMessages;
  If FCancel Then exit;
  SendSocketText('DELE ' + Inttostr(Index) + crlf);
  GetSocketText;
  If FPOPError Then
  begin
    HandleError(eeGeneral);
    exit;
  end;
  FDeletedItems.Add(inttostr(Index));
  dec(FVMessagesCount);
  If assigned(FOnDelete) Then FOnDelete(self,Index);
end;

Procedure TAHMPopMail.RetrieveMessage(Index :Word;GetHeaderOnly : Boolean);
Const
  EOM = crlf + '.' + crlf;
  NoValidChars = '\/:*?"<>|';
Var
  i,p,x,Line,position :Integer;
  boundary,endOfVMessage,CTEncoding,Conttype,FileName :String;
  AHMVMessage :TAHMMessage;
  Headers,HeadersPart,aPart,StrListVMessage :TStringList;
  Partes :TList;
  AttFile :TAHMAttachment;
  AllVMessage :TMemoryStream;
  found :Boolean;
  SText : String;
begin
  If Not FConnected Then Exception.create(AHMRcMailNotConn);
  If assigned(FOnBeforeRetrieve) Then FOnBeforeRetrieve(self,Index);
  AllVMessage := TMemoryStream.Create;
  if GetHeaderOnly then
    SendSocketText('TOP ' + intToStr(Index) + ' 0' + crlf)
  else
    SendSocketText('RETR '+intToStr(Index) + #13#10);
  SText := GetSocketText;
  if FPOPError Then
  begin
    HandleError(eeReceive);
    exit;
  end;
  If FHostMsg <> '' Then
  begin
    try
      FSize := strtoint(copy(FHostMsg,1,pos(' ',FHostMsg) - 1));
    except
      FSize := 100;
    end;
  end else FSize := 100;
  FStep := FCurrentAccount.ProgressStep;
  AllVMessage.Write(Pointer(SText)^,length(SText));
  while pos(EOM,SText) = 0 Do
  begin
    Application.ProcessMessages;
    if FCancel then  exit;
    SText := Copy(SText,Length(SText)-3,4)+GetSocketText;
    AllVMessage.Write(SText[5],length(SText) - 4);
    FRetrieveProgress := round(100*AllVMessage.Size/FSize);
    if (FRetrieveProgress >= FStep) then
    begin
      If assigned(FOnRetrieveProgress) Then FOnRetrieveProgress(self,FRetrieveProgress);
      Inc(FStep,FCurrentAccount.ProgressStep);
    end;
  end;
  if (FRetrieveProgress<100) and (assigned(FOnRetrieveProgress)) then FOnRetrieveProgress(self,100);
  SText := #0;
  AllVMessage.Write(SText[1],1);
  StrListVMessage := TStringList.Create;
  StrListVMessage.Text := PChar(AllVMessage.Memory);
  StrListVMessage.Delete(0);
  StrListVMessage.Delete(StrListVMessage.count-1);
  Headers := TStringList.Create;
  AHMVMessage := TAHMMessage.Create(Self.Messages);
  AHMVMessage.FAccount:=CurrentAccount;
  AHMVMessage.FIndex:=Index;
  I := StrListVMessage.IndexOf('');
  if (I<>-1) then for P:=0 to I do Headers.Add(StrListVMessage[P]);
  for P:=0 to I do StrListVMessage.Delete(0);
  I:=0;
  while (I<StrListVMessage.Count-1) do
  begin
    X:=Length(StrListVMessage[i]);
    if (Pos('.',StrListVMessage[i]) = 1) and (X>1) then StrListVMessage[I] := Copy(StrListVMessage[I],2,X);
    Inc(I);
  end;
  AHMVMessage.FromMail := Copy(Headers.Strings[0],6,72);
  if FindInHeaders('FROM:',Headers,Line) then
  begin
    AHMVMessage.FFromMail := Trim(Copy(Headers[Line],7,127)); X:=1;
    if (Headers[Line + x] <> '') then
    while Headers[Line + x][1]=' ' do
    begin
      AHMVMessage.FFromMail:=AHMVMessage.FFromMail+Trim(Headers[Line+X]);
      Inc(X);
    end;
    if pos('<',AHMVMessage.FFromMail)>0 then
    begin
      AHMVMessage.FFromName:=Copy(AHMVMessage.FFromMail,1,Pos('<',AHMVMessage.FFromMail)-1);
      while Pos('"',AHMVMessage.FFromname)>0 do Delete(AHMVMessage.FFromname,Pos('"',AHMVMessage.FFromname),1);
      AHMVMessage.FFromMail:=Copy(AHMVMessage.FFromMail,Pos('<',AHMVMessage.FFromMail) + 1,
        Pos('>',AHMVMessage.FFromMail) - Pos('<',AHMVMessage.FFromMail) - 1);
    end else AHMVMessage.FFromName:=AHMVMessage.FFrommail;
    while Pos(' ',AHMVMessage.FFromMail)>0 do Delete(AHMVMessage.FFromMail,pos(' ',AHMVMessage.FFromMail),1);
  end;
  if FindInHeaders('MESSAGE-ID:',Headers,Line) then AHMVMessage.FMessageId:=Trim(Copy(Headers[Line],13,127));
  if FExistingIDS.IndexOf(AHMVMessage.FMessageID)>-1 then
  begin
    AHMVMessage.Free;
    exit;
  end else FExistingIDS.Add(AHMVMessage.FMessageID);
  if FindInHeaders('IN-REPLY-TO:',Headers,Line) then AHMVMessage.FInReplyTo := trim(copy(Headers[Line],14,127));
  if FindInHeaders('REPLY-TO:',Headers,Line) then
  begin
    AHMVMessage.FReplyTo:=copy(Headers[Line],11,127); X:=1;
    if (Headers[Line+X]<>'') then
    while Headers[Line+X][1]=' ' do
    begin
      AHMVMessage.FReplyTo:=AHMVMessage.FReplyTo+trim(Headers[Line+X]);
      Inc(X);
    end;
  end else AHMVMessage.ReplyTo := AHMVMessage.FromMail;
  if FindInHeaders('TO:',Headers,Line) then
  begin
    AHMVMessage.FSendTo:=Trim(Copy(Headers[Line],5,Length(Headers[Line])-3));
    X:=1;
    if (Headers[Line+X]<>'') then
    while Headers[Line+X][1]=' ' do
    begin
      AHMVMessage.FSendTo:=AHMVMessage.FSendTo+' '+Trim(Headers[Line+X]);
      Inc(X);
    end;
    if Pos('<',AHMVMessage.FSendTo) > 0 then
    AHMVMessage.FSendTo:=Copy(AHMVMessage.FSendTo,Pos('<',AHMVMessage.FSendTo)+1,
        Pos('>',AHMVMessage.FSendTo)-Pos('<',AHMVMessage.FSendTo)-1);
    while Pos(' ',AHMVMessage.FSendTo)>0 do Delete(AHMVMessage.FSendTo,Pos(' ',AHMVMessage.FSendTo),1);
  end;
  if FindInHeaders('DATE:',Headers,Line) then AHMVMessage.FDate:=Trim(Copy(Headers[Line],7,72));
  if FindInHeaders('SUBJECT:',Headers,Line) then AHMVMessage.FSubject:=Trim(Copy(Headers[Line],10,Length(Headers[Line])));
  if FindInHeaders('CONTENT-TYPE:',Headers,Line) then
  begin
    Conttype := upperCase(Trim(copy(Headers[Line],15,72)));
    X:=pos(';',Conttype);
    if X>0 then Conttype := copy(Conttype,1,x - 1);
    Found:=True;
  end else Found:=False;
  if not(Found) or (Pos('TEXT',Conttype)>0) or (Conttype = 'MULTIPART/REPORT') or (Pos('MESSAGE',Conttype)>0) then
  begin
    Partes := TList.create;
    while GetUUAttachments(StrListVMessage,Line,FileName) do
    begin
      aPart := TStringList.create;
      Partes.add(aPart);
      while lowercase(trim(StrListVMessage[Line])) <> 'end' do
      begin
        if StrListVMessage[Line] <> '' then aPart.Add(StrListVMessage[Line]);
        StrListVMessage.Delete(Line);
      end;
      AHMVMessage.Attachments.add(FileName);
      AttFile := AHMVMessage.Attachments[AHMVMessage.Attachments.count - 1];
      AttFile.FBodyEncoded.Assign(aPart);
      UUDecode(AttFile);
      aPart.Free;
    end;
    Partes.Free;
    AHMVMessage.Message.Text := StrListVMessage.text;
    if assigned(FOnAfterRetrieve) then FOnAfterRetrieve(self,AHMVMessage);
    exit;
  end;
  if not(FindInStringList('BOUNDARY=',Headers,Line,position)) then
    HandleServerResponse(AHMRcMailErr,AHMRcMailInvalidMsgFormat,True);
  SText:=Headers.Strings[Line];
  boundary := trim(copy(SText,position + 9,72));
  if boundary[1] = '"' then
  begin
    delete(boundary,1,1);
    x := pos('"',boundary);
    delete(boundary,x,32);
  end;
  boundary := '--' + boundary;
  endOfVMessage := boundary + '--';
  if not(FCurrentAccount.HeaderOnly) then
  begin
    Partes := TList.create;
    aPart := TStringList.create;
    if not(FindInStringListCS(boundary,StrListVMessage,Line,position)) then HandleServerResponse(AHMRcMailErr,AHMRcMailInvalidMsgFormat,true);
    Inc(Line);
    while StrListVMessage[Line]<>endOfVMessage do
    begin
      if StrListVMessage[Line]=boundary then
      begin
        Partes.add(aPart);
        aPart := TStringList.create;
        inc(Line);
      end;
      aPart.add(StrListVMessage[Line]);
      inc(Line);
    end;
    partes.add(aPart);
    for p:=0 to Partes.count-1 do
    begin
      aPart := TStringList(partes[p]);
      HeadersPart := TStringList.Create;
      i:=0;
      while aPart[i]<>'' do
      begin
        HeadersPart.Add(aPart[i]);
        Inc(I);
      end;
      if FindInHeaders('CONTENT-TRANSFER-ENCODING:',HeadersPart,Line) then
         CTEncoding := Uppercase(Trim(Copy(HeadersPart[Line],28,20))) else CTEncoding := '';
      if FindInHeaders('CONTENT-TYPE:',HeadersPart,Line) then
      begin
        Conttype:=UpperCase(Trim(Copy(HeadersPart[Line],15,72)));
        X:=Pos(';',Conttype);
        if X>0 then Conttype := Copy(Conttype,1,X-1);
      end else Conttype := '';
      FileName := '';
      if FindInStringList('FILENAME=',HeadersPart,Line,position) then
      begin
        FileName := trim(copy(HeadersPart[Line],position + 10,127));
        delete(FileName,length(FileName),1);
      end else
      begin
        if FindInStringList('NAME=',HeadersPart,Line,position) then
        begin
          FileName:=Trim(Copy(HeadersPart[Line],Position + 5,127));
          if FileName[1]=#34 then
          begin
            Delete(FileName,1,1);
            Delete(FileName,length(FileName),1);
          end;
        end;
      end;
      HeadersPart.Free;
      if (CTEncoding='BASE64') or (FileName<>'') or (Conttype='TEXT/HTML') or (CTEncoding='X-UUENCODE') then
      begin
        if FileName='' then FileName:=Trim(AHMVMessage.Subject);
        for I:=1 to length(NoValidChars) do
        begin
          repeat
            x := pos(NoValidChars[i],FileName);
            if X>0 then delete(FileName,x,1);
          until X=0;
        end;
        if FileName='' then FileName := '_Cosa_';
        if Conttype='TEXT/HTML' then FileName := FileName + '.html';
        AHMVMessage.Attachments.add(FileName);
        while (trim(aPart[0])<>'') do aPart.delete(0);
        if (CTEncoding = 'BASE64') or (CTEncoding = 'X-UUENCODE') then
        while trim(aPart[0])='' do aPart.delete(0) else aPart.Delete(0);
        AttFile:=AHMVMessage.Attachments[AHMVMessage.Attachments.Count-1];
        if CTEncoding='BASE64' then
        begin
          AttFile.FBodyEncoded.Assign(aPart);
          Base64Decode(AttFile);
        end else
        if CTEncoding='X-UUENCODE' then
        begin
          AttFile.FBodyEncoded.Assign(aPart);
          UUDecode(AttFile);
        end else
        begin
          aPart.delete(aPart.count - 1);
          AttFile.FBodyBin.Write(Pointer(aPart.text)^,length(aPart.text));
        end;
      end else
      begin
        while aPart[0]<>'' do aPart.delete(0);
        aPart.delete(0);
        AHMVMessage.Message.AddStrings(aPart);
      end;
    end;
    Partes.Free;
  end;
  if assigned(FOnAfterRetrieve) then FOnAfterRetrieve(self,AHMVMessage);
end;

Function TAHMPopMail.RetrieveMessages : Integer;
var i,count :Integer;
begin
  count := 0;
  for i := 1 to FVMessagesCount do
  begin
    if (FDeletedItems.IndexOf(intToStr(i))=-1) then
    begin
      RetrieveMessage(I,FCurrentAccount.HeaderOnly);
      if FCurrentAccount.DeleteOffServer then DeleteMessage(i);
      if FCancel then break else inc(count);
    end;
  end;
  result := count;
end;

Procedure TAHMPopMail.Base64Decode(Var VAttachment :TAHMAttachment);
Var
  a1 :Array[1..4] Of byte;
  b1 :Array[1..3] Of byte;
  i,j,step :Integer;
  byte_ptr,real_bytes :Integer;
  VTxt :TStringList;
  Line :String;
begin
  VTxt := VAttachment.FBodyEncoded;
  If assigned(FOnDecodeStart) Then FOnDecodeStart(self,VAttachment.FileName,VTxt.Count);
  step := FCurrentAccount.ProgressStep;
  byte_ptr := 0;
  For i := 0 To VTxt.Count - 1 Do
  begin
    Line := VTxt[i];
    For j := 1 To Length(Line) Do
    begin
      Inc(byte_ptr);
      Case Line[j] Of
        'A'..'Z' :a1[byte_ptr] := Ord(Line[j]) - 65;
        'a'..'z' :a1[byte_ptr] := Ord(Line[j]) - 71;
        '0'..'9' :a1[byte_ptr] := Ord(Line[j]) + 4;
        '+' :a1[byte_ptr] := 62;
        '/' :a1[byte_ptr] := 63;
        '=' :a1[byte_ptr] := 64;
      end;
      If byte_ptr = 4 Then
      begin
        byte_ptr := 0;
        real_bytes := 3;
        If a1[1] = 64 Then real_bytes := 0;
        If a1[3] = 64 Then
        begin
          a1[3] := 0;
          a1[4] := 0;
          real_bytes := 1;
        end;
        If a1[4] = 64 Then
        begin
          a1[4] := 0;
          real_bytes := 2;
        end;
        b1[1] := a1[1] * 4 + (a1[2] Div 16);
        b1[2] := (a1[2] Mod 16) * 16 + (a1[3] Div 4);
        b1[3] := (a1[3] Mod 4) * 64 + a1[4];
        VAttachment.FBodyBin.Write(b1,real_bytes);
        FDecodeProgress := Round(100 * i / VTxt.Count);
        If (FDecodeProgress >= step) Then
        begin
          If assigned(FOnDecodeProgress) Then FOnDecodeProgress(self,FDecodeProgress);
          inc(step,FCurrentAccount.ProgressStep);
        end;
        Application.ProcessMessages;
      end;
    end;
  end;
  If (FDecodeProgress < 100) And (assigned(FOnDecodeProgress))
    Then FOnDecodeProgress(self,100);
  If assigned(FOnDecodeEnd) Then FOnDecodeEnd(self);
end;


Procedure TAHMPopMail.UUDecode(Var VAttachment :TAHMAttachment);
Const
  Table = '`!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_';
Var
  A45Bytes :Array[1..45] Of byte;
  A24Bits :Array[0..8 * 45] Of Boolean;
  i,j,k,b,m,BytesGenerated,step :Word;
  ndx :LongInt;
  VTxt :TStringList;
  Line :String;
  LineLen,ActualLen :byte;
  buff :TMemoryStream;
  Function ByteFromTable(Ch :Char) :byte;
  Var
    n :byte;
  begin
    n := 1;
    While (Ch <> Table[n]) And (n <= 64) Do Inc(n);
    If n > 64 Then
    begin
      if not(Ch = ' ') then HandleServerResponse(AHMRcMailErr,AHMRcMailInvalidMsgFormat,True);
    end;
    Result := n - 1;
  end;
begin
  VTxt := VAttachment.FBodyEncoded;
  If assigned(FOnDecodeStart) Then FOnDecodeStart(self,VAttachment.FileName,VTxt.Count);
  step := FCurrentAccount.ProgressStep;
  buff := TMemoryStream.create;
  Try
    ndx := 1;
    Repeat
      Line := VTxt.Strings[ndx];
      FillChar(A45Bytes,45,0);
      FillChar(A24Bits,8 * 45 + 1,0);
      k := 0;
      LineLen := length(Line);
      ActualLen := 4 * ByteFromTable(Line[1]) Div 3;
      If ActualLen <> (4 * 45 Div 3) Then ActualLen := LineLen - 1;
      For i := 2 To ActualLen + 1 Do
      begin
        b := ByteFromTable(Line[i]);
        For j := 5 Downto 0 Do
        begin
          m := 1 Shl j;
          If (b And m = m) Then A24Bits[k] := true;
          Inc(k);
        end;
      end;
      k := 0;
      For i := 1 To 45 Do
      begin
        b := 0;
        For j := 7 Downto 0 Do
        begin
          If A24Bits[k] Then b := b Or (1 Shl j);
          Inc(k);
        end;
        A45Bytes[i] := b;
      end;
      BytesGenerated := ByteFromTable(Line[1]);
      Buff.Write(A45Bytes,BytesGenerated);
      FDecodeProgress := Round(100 * ndx / VTxt.Count);
      If (FDecodeProgress >= step) Then
      begin
        If assigned(FOnDecodeProgress) Then FOnDecodeProgress(self,FDecodeProgress);
        inc(step,FCurrentAccount.ProgressStep);
      end;
      Application.ProcessMessages;
      Inc(ndx);
    Until (ndx = VTxt.Count) Or (VTxt[ndx] = 'end') Or (VTxt[ndx] = Table[1]);
  Finally
    VAttachment.FBodyBin := buff;
    If (FDecodeProgress < 100) And (assigned(FOnDecodeProgress))
      Then FOnDecodeProgress(self,100);
    If assigned(FOnDecodeEnd) Then FOnDecodeEnd(self);
  end;
end;

Function TAHMPopMail.GetUUAttachments(Const StrList :TStringList;
  Var Line :Integer;
  Var FileName :String) :Boolean;
Var
  s,que,permiss :String;
  position,intPermiss :Integer;
begin
  result := false;
  intPermiss := 0;
  If StrList.Count = 0 Then exit;
  Line := 0;
  que := 'begin';
  Repeat
    s := lowerCase(StrList[Line]);
    position := pos(que,s);
    If position = 1 Then
      If length(s) > 10 Then
      begin
        permiss := copy(s,7,3);
        Try
          intPermiss := StrToInt(permiss);
        Except
          inc(Line);
          continue;
        end;
        If intPermiss < 777 Then
        begin
          FileName := copy(StrList[Line],11,64);
          result := true;
          break;
        end;
      end;
    inc(Line);
  Until Line = StrList.count;
end;

Function TAHMPopMail.FindInHeaders(Const que :String;Const StrList :TStringList;
  Var Line :Integer) :Boolean;
Var
  s :String;
  position :Integer;
begin
  result := false;
  If StrList.Count = 0 Then exit;
  Line := 0;
  Repeat
    s := upperCase(StrList[Line]);
    position := pos(que,s);
    If position = 1 Then break;
    inc(Line);
  Until Line = StrList.count;
  If Line <> StrList.count Then result := true;
end;

Function TAHMPopMail.FindInStringList(Const que :String;Const StrList :TStringList;
  Var Line,position :Integer) :Boolean;
Var
  s :String;
begin
  result := false;
  If StrList.Count = 0 Then exit;
  Line := 0;
  Repeat
    s := upperCase(StrList[Line]);
    position := pos(que,s);
    If position > 0 Then break;
    inc(Line);
  Until Line = StrList.count;
  If Line <> StrList.count Then result := true;
end;

Function TAHMPopMail.FindInStringListCS(Const que :String;Const StrList :TStringList;
  Var Line,position :Integer) :Boolean;
begin
  result := false;
  If StrList.Count = 0 Then exit;
  Line := 0;
  Repeat
    If pos(que,StrList[Line]) > 0 Then break;
    inc(Line);
  Until Line = StrList.count;
  If Line <> StrList.count Then result := true;
end;


Function TAHMPopMail.GetSocketText :String;
Var
  s :String;
  x :Integer;
  buff :Array[1..1024] Of char;
begin
  if (FSocket<>nil) then
  if (FSocket.Active) and (FSocketStream<>nil) then
  begin
    while not FSocketStream.WaitForData(FCurrentAccount.TimeOut*100) do Application.ProcessMessages;
    x := FSocketStream.read(buff,1024);
    s := copy(buff,1,x);
    FHostStatus:=UpperCase(Trim(Copy(s,1,4)));
    FHostMsg:=Trim(Copy(s,5,Pos(crlf,s) - 5));
    FPOPError := UpperCase(FHostStatus) = AHMRcMailErr;
    if Assigned(FOnServerMessage) then FOnServerMessage(Self,FHostStatus,FHostMsg);
    result := s;
  end else FPopError:=True;
end;

Procedure TAHMMailHost.SendSocketText(Const SocketText :String);
begin
  if (FSocket<>nil) then
  if (FSocket.Active) and (FSocketStream<>nil) then
  FSocketStream.write(pchar(SocketText)^,length(SocketText));
end;

Procedure TAHMMailHost.HandleErrorAndExit(Sender :TObject;Socket :TCustomWinSocket;ErrorEvent :TErrorEvent;Var ErrorCode :Integer);
begin
  FCancel := True;
  Disconnect;
  HandleServerResponse(InttoStr(ErrorCode),FHostStatus+' '+FHostMsg,True);
end;


procedure TAHMMailHost.Connect(Server: String; Port, TimeOut: Integer);
begin
  FSocket.port := Port;
  FSocket.host := Server;
  try
    FSocket.Open;
  except
    FHostMsg:=AHMRCMailCanNotConnect;
    HandleError(eeConnect);
    exit;
  end;
  FSocketStream := TWinSocketStream.create(FSocket.Socket,TimeOut*100);
  while not(FConnected) do Application.ProcessMessages;
end;

function TAHMMailHost.GetSocketText: String;
begin
  {}
end;

end.

