Pascal (Lazarus/Delphi)

Copy Email from one IMAP Account to Another

See more IMAP Examples

Demonstrates how to copy the email in a mailbox from one account to another. Pascal (Lazarus/Delphi)

program ChilkatDemo;

// Demonstrates using the Chilkat Pascal wrapper via the C bridge DLL.
// Builds as a console application under Lazarus (FPC) or Delphi.

{$IFDEF FPC}
  {$MODE DELPHI}
{$ENDIF}
{$APPTYPE CONSOLE}

uses
  {$IFDEF UNIX}
  cthreads,
  {$ENDIF}
  SysUtils,
  CkDllLoader,
  Chilkat.FileAccess,
  Chilkat.Imap,
  Chilkat.StringBuilder,
  Chilkat.MessageSet;

// ---------------------------------------------------------------------------

procedure RunDemo;
var
  success: Boolean;
  imapSrc: TImap;
  imapDest: TImap;
  fetchUids: Boolean;
  mset: TMessageSet;
  fac: TFileAccess;
  msetAlreadyCopied: TMessageSet;
  strMsgSet: string;
  numUids: Integer;
  sbFlags: TStringBuilder;
  i: Integer;
  uid: Integer;
  flags: string;
  mimeStr: string;
  seen: Boolean;
  flagged: Boolean;
  answered: Boolean;
  draft: Boolean;

begin
  success := False;

  imapSrc := TImap.Create;

  //  This example requires the Chilkat API to have been previously unlocked.
  //  See Global Unlock Sample for sample code.

  //  Connect to our source IMAP server.
  imapSrc.Ssl := True;
  imapSrc.Port := 993;
  success := imapSrc.Connect('MY-IMAP-DOMAIN');
  if (success <> True) then
    begin
      WriteLn(imapSrc.LastErrorText);
      Exit;
    end;

  //  Login to the source IMAP server
  success := imapSrc.Login('MY-IMAP-LOGIN','MY-IMAP-PASSWORD');
  if (success <> True) then
    begin
      WriteLn(imapSrc.LastErrorText);
      Exit;
    end;

  imapDest := TImap.Create;

  //  Connect to our destination IMAP server.
  imapDest.Ssl := True;
  imapDest.Port := 993;
  success := imapDest.Connect('MY-IMAP-DOMAIN2');
  if (success <> True) then
    begin
      WriteLn(imapDest.LastErrorText);
      Exit;
    end;

  //  Login to the destination IMAP server
  success := imapDest.Login('MY-IMAP-LOGIN2','MY-IMAP-PASSWORD2');
  if (success <> True) then
    begin
      WriteLn(imapDest.LastErrorText);
      Exit;
    end;

  //  Select a source IMAP mailbox on the source IMAP server
  success := imapSrc.SelectMailbox('Inbox');
  if (success <> True) then
    begin
      WriteLn(imapSrc.LastErrorText);
      Exit;
    end;

  fetchUids := True;

  //  Get the set of UIDs for all emails on the source server.
  mset := imapSrc.Search('ALL',fetchUids);
  if (imapSrc.LastMethodSuccess <> True) then
    begin
      WriteLn(imapSrc.LastErrorText);
      Exit;
    end;

  //  Load the complete set of UIDs that were previously copied.
  //  We dont' want to copy any of these to the destination.
  fac := TFileAccess.Create;
  msetAlreadyCopied := TMessageSet.Create;
  strMsgSet := fac.ReadEntireTextFile('qa_cache/saAlreadyLoaded.txt','utf-8');
  if (fac.LastMethodSuccess = True) then
    begin
      msetAlreadyCopied.FromCompactString(strMsgSet);
    end;

  numUids := mset.Count;
  sbFlags := TStringBuilder.Create;

  i := 0;
  while i < numUids do
    begin

      //  If this UID was not already copied...
      uid := mset.GetId(i);
      if (not msetAlreadyCopied.ContainsId(uid)) then
        begin

          WriteLn('copying ' + uid + '...');

          //  Get the flags.
          flags := imapSrc.FetchFlags(uid,True);
          if (imapSrc.LastMethodSuccess = False) then
            begin
              WriteLn(imapSrc.LastErrorText);
              Exit;
            end;
          sbFlags.SetString(flags);

          //  Get the MIME of this email from the source.
          mimeStr := imapSrc.FetchSingleAsMime(uid,True);
          if (imapSrc.LastMethodSuccess = False) then
            begin
              WriteLn(imapSrc.LastErrorText);
              Exit;
            end;

          seen := sbFlags.Contains('\\Seen',False);
          flagged := sbFlags.Contains('\\Flagged',False);
          answered := sbFlags.Contains('\\Answered',False);
          draft := sbFlags.Contains('\\Draft',False);

          success := imapDest.AppendMimeWithFlags('Inbox',mimeStr,seen,flagged,answered,draft);
          if (success <> True) then
            begin
              WriteLn(imapDest.LastErrorText);
              Exit;
            end;

          //  Update msetAlreadyCopied with the uid just copied.
          msetAlreadyCopied.InsertId(uid);

          //  Save at every iteration just in case there's a failure..
          strMsgSet := msetAlreadyCopied.ToCompactString();
          fac.WriteEntireTextFile('qa_cache/saAlreadyLoaded.txt',strMsgSet,'utf-8',False);
        end;

      i := i + 1;
    end;

  mset.Free;

  //  Disconnect from the IMAP servers.
  success := imapSrc.Disconnect();
  success := imapDest.Disconnect();


  imapSrc.Free;
  imapDest.Free;
  fac.Free;
  msetAlreadyCopied.Free;
  sbFlags.Free;

end;

// ---------------------------------------------------------------------------

begin

  try
    RunDemo;
  except
    on E: Exception do
      WriteLn('Unhandled exception: ', E.ClassName, ': ', E.Message);
  end;

  WriteLn;
  {$IFDEF MSWINDOWS}
  WriteLn('Press Enter to exit...');
  ReadLn;
  {$ENDIF}
end.