Development

unit MainUnit;

(*
 In the preceding example we saw the structure (tree) of our MailBox.
 Now we will try to show the contents of each folder.

 Most people think of e-mails as messages.
 However, MAPI perceives each element in a folder as a message.
 The calendar, letters, contacts - all these are messages of different classes.
 But we will discuss this later.

 Now, let's get to what we want to do - visualize the contents of a folder.
 When we select a folder in the MailBox, we will show its contents in
 the right-hand window.
 This task will be performed by the EnumThisFolder function.

 Legal comment of the new MAPI functions.
 No functions that we have used in the previous examples are explained.

 This example requires connection with Exchange Server for efficient implementation.
*)

interface

{ Please add "..\Library" to project search path }
{$I IMI.INC}

uses
  Classes, Controls, Forms, Graphics, Buttons, ComCtrls, ExtCtrls, ImgList,
  StdCtrls, Windows, ExtendedMAPI, System.ImageList;

type

  PMessageProperties = ^TMessageProperties;

  TMessageProperties = record
    HASATTACH: boolean;
    SUBJECT: PChar;
    MESSAGE_SIZE: ULONG;
    CLIENT_SUBMIT_TIME: TDateTime;
  end;

type
  TfrmMain = class(TForm)
    plTOP: TPanel;
    btLogOn: TSpeedButton;
    btLogOff: TSpeedButton;
    rgProfile: TRadioGroup;
    MailboxTreeView: TTreeView;
    ilMailboxes: TImageList;
    Splitter1: TSplitter;
    lvMailbox: TListView;
    StatusBar1: TStatusBar;
    rbStore: TRadioGroup;
    procedure FormCreate(Sender: TObject);
    procedure btLogOnClick(Sender: TObject);
    procedure btLogOffClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure MailboxTreeViewClick(Sender: TObject);
    procedure lvMailboxData(Sender: TObject; Item: TListItem);
    procedure lvMailboxColumnClick(Sender: TObject; Column: TListColumn);
  private
    { Private declarations }
    hr: HRESULT;
    FMapiSession: IMAPISession;
    FMDB: IMsgStore;
    FFolderListMessages: TList;
    FNode: TTreeNode;
    procedure ClearMAPIInterfaces;
    procedure MAPILocalInit(Flag: cardinal);
    procedure MapiInternalLogOff;
    procedure OpenPrivateIS;
    procedure GetFolderRoot;
    procedure ClearViewList;
    procedure EnumFolders(ParentFolder: IMAPIFolder; ParentNode: TTreeNode);
    procedure EnumThisFolder(Value: PSBinary);
    function ShellItem(Index: integer): PMessageProperties;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

uses
{$IFDEF DELPHI2011XE2}
  UITypes,
{$ENDIF}
  SysUtils, Variants, DateUtils, StrUtils, Dialogs, EDK, MAPIMacros,
  MAPIUtils, MAPIVariantProp, MAPIFldUtils;

var
  ColumnToSort: integer;
{$R *.DFM}
{$I XE.INC}

procedure ClearFIMList(var Value: TList);
var
  I: integer;
  V: PMessageProperties;
begin
  try
    for I := 0 to (Value.Count - 1) do
    begin
      V := Value[I];
      if Assigned(V^.SUBJECT) then
        FreeMem(V^.SUBJECT);
      V^.SUBJECT := nil;
      FreeMem(V);
      Value[I] := nil;
    end;
  finally
    if (Value.Count > 0) then
      Value.Clear;
  end;
end;

procedure TfrmMain.ClearMAPIInterfaces;
begin
  FMDB := nil;
  FMapiSession := nil;
end;

procedure TfrmMain.MAPILocalInit(Flag: cardinal);
begin
  ClearTTreeBinary(MailboxTreeView);

  hr := MAPILogonEx(Application.Handle, nil, nil, MAPI_EXTENDED or MAPI_NEW_SESSION or MAPI_NO_MAIL or Flag, FMapiSession);

  if Failed(hr) then
  begin
    case hr of
      MAPI_E_LOGON_FAILED:
        MessageDlg(WrapText(
            'The logon did not succeed, either because one or more of the parameters to Profile were invalid or because there were too many sessions open already.'
              , #13#10, ['.', ' '], 42), mtError, [mbOK], 0);
      MAPI_E_TIMEOUT:
        MessageDlg(WrapText('MAPI serializes all logons through a mutex. This is returned if the another thread held the mutex.', #13#10, ['.', ' '], 42),
          mtError, [mbOK], 0);
      MAPI_E_USER_CANCEL:
        ShowMessage(WrapText('The user canceled the operation, typically by choosing the Cancel button in a dialog box.', #13#10, ['.', ' '], 42));
      MAPI_E_TOO_MANY_SESSIONS:
        MessageDlg(WrapText('The user had too many sessions open simultaneously. No session handle was returned.', #13#10, ['.', ' '], 42), mtError, [mbOK], 0);
      MAPI_E_UNCONFIGURED:
        MessageDlg(WrapText('A service provider has not been configured, and therefore the operation did not complete.', #13#10, ['.', ' '], 42), mtError,
          [mbOK], 0);
    else
      MessageDlg(WrapText('The logon did not succeed', #13#10, ['.', ' '], 42), mtError, [mbOK], 0);
    end;
  end;

  if Failed(hr) then
  begin
    FMapiSession := nil;
  end;

  btLogOn.Enabled := not Assigned(FMapiSession);
  btLogOff.Enabled := Assigned(FMapiSession);
  if Assigned(FMapiSession) then
    OpenPrivateIS;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
var
  ErrorString: string;
  MAPIINIT: TMAPIINIT; // MAPI Init Structure
begin
{$IF DEFINED (WIN64)}
  Self.Caption := Self.Caption + ' - WIN64';
{$ELSE}
  Self.Caption := Self.Caption + ' - WIN32';
{$IFEND}
  FNode := nil;
  FFolderListMessages := TList.Create;
  ClearMAPIInterfaces;

  MAPIINIT.ulVersion := MAPI_INIT_VERSION;
  MAPIINIT.ulFlags := 0;

  hr := MapiInitialize(@MAPIINIT);

  if Failed(hr) then
  begin
    case hr of
      MAPI_E_INVALID_PARAMETER or MAPI_E_UNKNOWN_FLAGS:
        ErrorString := 'Invalid parameter or flag!';
      MAPI_E_TOO_COMPLEX:
        ErrorString := 'The keys required by MAPI could not be initialized.';
      MAPI_E_VERSION:
        ErrorString := 'The version of OLE installed on the workstation is not compatible with this version of MAPI.';
      MAPI_E_SESSION_LIMIT:
        ErrorString := 'MAPI sets up context specific to the current process.' + #13 +
          'Failures may occur on Win16 if the number of processes exceeds a certain number,' + #13 + 'or on any system if available memory is exhausted.';
      MAPI_E_NOT_ENOUGH_RESOURCES:
        ErrorString := 'Not enough system resources were available to complete the operation.';
      MAPI_E_INVALID_OBJECT:
        ErrorString := 'May fail if system resources are exhausted.';
      MAPI_E_NOT_INITIALIZED:
        ErrorString := 'The MAPI profile provider has encountered an error.';
    else
      ErrorString := 'The MAPI Error!'
    end;
    Raise Exception.Create(ErrorString);
  end;

end;

procedure TfrmMain.ClearViewList;
var
  Count: integer;
  P: PSBinary;
begin
  if lvMailbox.Items.Count < 1 then
    exit;
  lvMailbox.Items.BeginUpdate;

  try
    for Count := 0 to lvMailbox.Items.Count - 1 do
    begin
      P := PSBinary(lvMailbox.Items[Count].Data);
      FreePSBinary(P);
      lvMailbox.Items[Count].Data := nil;
    end;
  finally
    lvMailbox.Items.Clear;
    lvMailbox.Items.EndUpdate;
  end;
end;

procedure TfrmMain.MapiInternalLogOff;
var
  Flags: ULONG;
begin
  ClearTTreeBinary(MailboxTreeView);
  ClearViewList;
  Application.ProcessMessages;

  Flags := LOGOFF_NO_WAIT;

  if Assigned(FMDB) then
  begin
    FMDB.StoreLogoff(Flags);
    FMDB := nil;
  end;

  if Assigned(FMapiSession) then
  begin
    FMapiSession.Logoff(Application.Handle, MAPI_LOGOFF_UI, 0);
    FMapiSession := nil;
  end;

  StatusBar1.Panels.Clear;
end;

procedure TfrmMain.btLogOnClick(Sender: TObject);
begin
  case rgProfile.ItemIndex of
    0:
      MAPILocalInit(MAPI_USE_DEFAULT or MAPI_PASSWORD_UI);
    1:
      MAPILocalInit(MAPI_LOGON_UI);
  end;
end;

procedure TfrmMain.btLogOffClick(Sender: TObject);
begin
  MapiInternalLogOff;
  btLogOn.Enabled := True;
  btLogOff.Enabled := False;
end;

procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  ClearFIMList(FFolderListMessages);
  FFolderListMessages.Free;
  MapiInternalLogOff;
  MAPIUninitialize;
end;

procedure TfrmMain.OpenPrivateIS;
var
  Flags: ULONG;
  ENTRYID: TSBinary;
begin
  Flags := LOGOFF_NO_WAIT;
  FMDB := nil;

  if rbStore.ItemIndex = 0 then
    hr := HrOpenExchangePrivateStore(FMapiSession, FMDB)
  else
  begin
    ENTRYID.cb := 0;
    ENTRYID.lpb := nil;

    (* We may not restrict ourselves to Exchage Server only.
      EDK provides us with a function that "finds" Default mailbox associated
      with our MAPI profile.
      Thus we won't have to think about whether our application will connect
      to a server or use Private Store *)

    hr := HrMAPIFindDefaultMsgStore(FMapiSession, ENTRYID.cb, PENTRYID(ENTRYID.lpb));

    if Failed(hr) then
    begin
      ShowMessage('I cannot find "Default MsgStore"' + CRLF + GETMAPIError(FMapiSession, hr));
      exit;
    end;

    hr := FMapiSession.OpenMsgStore(Application.Handle,
    ENTRYID.cb, PENTRYID(ENTRYID.lpb),
    @IID_IMsgStore, MAPI_BEST_ACCESS  or MDB_ONLINE , FMDB);

    if hr = MAPI_E_UNKNOWN_FLAGS then
      hr := FMapiSession.OpenMsgStore(Application.Handle,
      ENTRYID.cb, PENTRYID(ENTRYID.lpb),
      @IID_IMsgStore, MAPI_BEST_ACCESS, FMDB);


    if Assigned(ENTRYID.lpb) then
      MAPIFreeBuffer(ENTRYID.lpb);

  end;

  if Failed(hr) then
  begin
    if Assigned(FMDB) then
      FMDB.StoreLogoff(Flags);
    FMDB := nil;

    ShowMessage('I can''t open "Store"' + CRLF + GETMAPIError(FMapiSession, hr));
    exit;
  end
  else
    GetFolderRoot;

end;

procedure TfrmMain.GetFolderRoot;
var
  RootFolder: IMAPIFolder;

  RowCount, ObjType: ULONG;

  iCount: integer;

  HierarchyTable: IMAPITable;

  PropTagArray: PSPropTagArray;

  PRows: PSRowSet;
  SlaveFolder: IMAPIFolder;
  Node: TTreeNode;

begin

  RootFolder := nil;
  HierarchyTable := nil;
  PropTagArray := nil;
  PRows := nil;
  SlaveFolder := nil;

  try

    hr := FMDB.OpenEntry(0, // use 0 for root folder
      nil, // use NIL for root folder
      @IID_IMAPIFolder, // use NULL for interface ID
      MAPI_DEFERRED_ERRORS, // use this flag if you plan to make changes
      ObjType, IUnknown(RootFolder));

    if Failed(hr) then
    begin
      ShowMessage(GETMAPIError(FMDB, hr));
      exit;
    end;

    hr := RootFolder.GetHierarchyTable(CONVENIENT_DEPTH, HierarchyTable);

    if Failed(hr) then
    begin
      ShowMessage(GETMAPIError(RootFolder, hr));
      exit;
    end;

    hr := HierarchyTable.GetRowCount(0, RowCount);

    if Failed(hr) then
    begin
      ShowMessage(GETMAPIError(HierarchyTable, hr));
      exit;
    end;

    hr := SizedSPropTagArray([PR_DISPLAY_NAME, PR_ENTRYID], PropTagArray);
    if Failed(hr) then
    begin
      ShowMessage('MAPIError');
      exit;
    end;

    hr := HierarchyTable.SetColumns(PropTagArray, 0);
    if Failed(hr) then
    begin
      ShowMessage(GETMAPIError(HierarchyTable, hr));
      exit;
    end;

    hr := HierarchyTable.QueryRows(RowCount, 0, PRows);

    if Failed(hr) then
    begin
      ShowMessage(GETMAPIError(HierarchyTable, hr));
      exit;
    end;

    if Assigned(PRows) and (PRows.cRows > 0) then
      for iCount := 0 to PRows.cRows - 1 do
        if (PSPropValueArray(PRows.aRow[iCount].lpProps)[0].ulPropTag = PR_DISPLAY_NAME) and Assigned
          (PSPropValueArray(PRows.aRow[iCount].lpProps)[0].Value.lpsz) then
          if (AnsiContainsText(StrPas(PSPropValueArray(PRows.aRow[iCount].lpProps)[0].Value.lpsz),
              'Top of ') or AnsiContainsText(StrPas(PSPropValueArray(PRows.aRow[iCount].lpProps)[0].Value.lpsz), 'IPM_SUBTREE')) then
          begin
            hr := FMDB.OpenEntry(PSPropValueArray(PRows.aRow[iCount].lpProps)[1].Value.bin.cb,
              PENTRYID(PSPropValueArray(PRows.aRow[iCount].lpProps)[1].Value.bin.lpb), @IID_IMAPIFolder, MAPI_DEFERRED_ERRORS, ObjType, IUnknown(SlaveFolder));

            if Failed(hr) then
            begin
              ShowMessage(GETMAPIError(FMDB, hr));
              exit;
            end;

            ClearTTreeBinary(MailboxTreeView);
            MailboxTreeView.Items.BeginUpdate;

            Node := MailboxTreeView.Items.AddFirst(nil, 'Mailbox');
            Node.ImageIndex := 0;

            EnumFolders(SlaveFolder, Node);

            SlaveFolder := nil;
            MailboxTreeView.Items.EndUpdate;
            break;
          end;


     // Use the GetTopFolder function !!!
    if MailboxTreeView.Items.Count = 0 then
    begin
      SlaveFolder := GetTopFolder(FMDB, True);
      if not Assigned(SlaveFolder) then
        Exit;

      ClearTTreeBinary(MailboxTreeView);
      MailboxTreeView.Items.BeginUpdate;

      Node := MailboxTreeView.Items.AddFirst(nil, 'Mailbox');
      Node.ImageIndex := 0;

      (* our recursion function *)
      EnumFolders(SlaveFolder, Node);

      SlaveFolder := nil;
      MailboxTreeView.Items.EndUpdate;
    end;

  finally
    if Assigned(RootFolder) then
      RootFolder := nil;
    if Assigned(PRows) then
      FreePRows(PRows);
    if Assigned(PropTagArray) then
      MAPIFreeBuffer(PropTagArray);
    if Assigned(HierarchyTable) then
      HierarchyTable := nil;
    if Assigned(SlaveFolder) then
      SlaveFolder := nil;
  end;
end;

procedure TfrmMain.EnumFolders(ParentFolder: IMAPIFolder; ParentNode: TTreeNode);
var
  SubFolder: IMAPIFolder;
  SubNode: TTreeNode;

  HierarchyTable: IMAPITable;

  ObjType, Count, RowCount: ULONG;

  RowSet: PSRowSet;

  PropTagArray: TSPropTagArray;
  FolderPropTagArray: PSPropTagArray;

  MAPIProp: IMAPIProp;

  ValueArray: PSPropValue;

  ENTRYID: PSBinary;
begin

  HierarchyTable := nil;
  RowSet := nil;
  FolderPropTagArray := nil;
  MAPIProp := nil;

  try
    if Assigned(ParentFolder) then
    begin
      hr := ParentFolder.GetHierarchyTable(0, HierarchyTable);
      if Failed(hr) then
      begin
        ShowMessage(GETMAPIError(ParentFolder, hr));
        exit;
      end;

      hr := HierarchyTable.GetRowCount(0, RowCount);
      if Failed(hr) then
      begin
        ShowMessage(GETMAPIError(HierarchyTable, hr));
        exit;
      end;

      PropTagArray.cValues := 1;
      PropTagArray.aulPropTag[0] := PR_ENTRYID;

      hr := HierarchyTable.SetColumns(@PropTagArray, 0);
      if Failed(hr) then
      begin
        ShowMessage(GETMAPIError(HierarchyTable, hr));
        exit;
      end;

      hr := HierarchyTable.QueryRows(RowCount, 0, RowSet);
      if Failed(hr) then
      begin
        ShowMessage(GETMAPIError(HierarchyTable, hr));
        exit;
      end;

      if Assigned(RowSet) and (RowSet.cRows > 0) then
      begin
        hr := SizedSPropTagArray([PR_DISPLAY_NAME, PR_ENTRYID, PR_SUBFOLDERS], FolderPropTagArray);
        if Failed(hr) then
        begin
          ShowMessage('MAPI Error');
          exit;
        end;

        for Count := 0 to RowSet.cRows - 1 do
        begin
          Application.ProcessMessages;

          hr := ParentFolder.OpenEntry(PSPropValueArray(RowSet.aRow[Count].lpProps)[0].Value.bin.cb,
            PENTRYID(PSPropValueArray(RowSet.aRow[Count].lpProps)[0].Value.bin.lpb), @IID_IMAPIProp, 0, ObjType, IUnknown(MAPIProp));

          if Failed(hr) then
          begin
            ShowMessage(GETMAPIError(ParentFolder, hr));
            exit;
          end;

          hr := MAPIProp.GetProps(FolderPropTagArray, 0, ObjType, ValueArray);

          if Failed(hr) then
          begin
            ShowMessage(GETMAPIError(MAPIProp, hr));
            exit;
          end;

          (*
           In order to be able to then open the folder and take its contents
           we will require ENTRYID. Since it is a Pointer we will store it in
           the TtreeNode and then we will use it to get an interface to the IMAPIFolder
           *)

          MakePSBinary(PSPropValueArray(ValueArray)[1].Value.bin, ENTRYID);

          SubNode := MailboxTreeView.Items.AddChildObject(ParentNode, StrPas(PSPropValueArray(ValueArray)[0].Value.lpsz), ENTRYID);

          SubNode.ImageIndex := 1;
          SubNode.SelectedIndex := 1;

          if BOOL(PSPropValueArray(ValueArray)[2].Value.B) and Assigned(SubNode.Data) then
          begin
            hr := ParentFolder.OpenEntry(PSBinary(SubNode.Data).cb, PENTRYID(PSBinary(SubNode.Data).lpb), @IID_IMAPIFolder, MAPI_DEFERRED_ERRORS, ObjType,
              IUnknown(SubFolder));
            if Failed(hr) then
            begin
              ShowMessage(GETMAPIError(ParentFolder, hr));
              exit;
            end;

            EnumFolders(SubFolder, SubNode);
            SubFolder := nil;
          end;

          MAPIFreeBuffer(ValueArray);
          ValueArray := nil;
          MAPIProp := nil;
        end; // for iCount:=0

        MAPIFreeBuffer(FolderPropTagArray);
        FolderPropTagArray := nil;

        FreePRows(RowSet);
        RowSet := nil;
      end; // if Assigned(PRows)

      HierarchyTable := nil;
    end; // if Assigned(ParentFolder)

  finally
    if Assigned(ValueArray) then
      MAPIFreeBuffer(ValueArray);
    ValueArray := nil;

    if Assigned(FolderPropTagArray) then
      MAPIFreeBuffer(FolderPropTagArray);
    FolderPropTagArray := nil;

    if Assigned(RowSet) then
      FreePRows(RowSet);
    RowSet := nil;

    if Assigned(MAPIProp) then
      MAPIProp := nil;
    if Assigned(HierarchyTable) then
      HierarchyTable := nil;

  end;
end;

procedure TfrmMain.MailboxTreeViewClick(Sender: TObject);
begin
  if Assigned(MailboxTreeView.Selected) then
    if FNode <> MailboxTreeView.Selected then
    begin
      FNode := MailboxTreeView.Selected;
      (*
       If you remember, our  Pointer containing  TtreeNode was an EntryID of the masked as a TSBinary
       *)

      Self.Enabled := False;
      try
        if Assigned(FNode.Data) then
          EnumThisFolder(PSBinary(FNode.Data));
      finally
        Self.Enabled := True;
      end;
    end;
end;

procedure TfrmMain.EnumThisFolder(Value: PSBinary);
var
  ContentTablePropTagArray: PSPropTagArray;
  SortOrderSet: TSSortOrderSet;
  MAPIFolder: IMAPIFolder;
  iCount, MessageSizeCount, ContentTableRowCount, ObjType: ULONG;
  ContentTable: IMAPITable;
  ContentTableRows: PSRowSet;
  MessageProperty: PMessageProperties;
  ProgresBar: TProgressBar;

begin
  ProgresBar := nil;
  MessageSizeCount := 0;

  ClearViewList;

  lvMailbox.Items.BeginUpdate;

  try
    ProgresBar := nil;
    MessageSizeCount := 0;
    StatusBar1.Panels.Clear;

    (*
     If you remember, our  Pointer containing  TtreeNode was an EntryID
     of the masked as a TSBinary.
     We will get an interface to the folder by making our Message Store open it.
     *)

    hr := FMDB.OpenEntry(Value.cb, PENTRYID(Value.lpb), @IID_IMAPIFolder, MAPI_DEFERRED_ERRORS, // or MAPI_BEST_ACCESS
      ObjType, IUnknown(MAPIFolder));

    if Failed(hr) then
    begin
      ShowMessage(GETMAPIError(FMDB, hr));
      exit;
    end;

    try
      ClearFIMList(FFolderListMessages);

      lvMailbox.Items.Count := FFolderListMessages.Count;
      Application.ProcessMessages;
      lvMailbox.Repaint;
    except
      ShowMessage('Error');
      hr := E_UNEXPECTED;
      exit;
    end;

    (*
     We will define the initial sorting of the table containing the messages.
     We will require sorting by "time of sending" of e-mails.
     We don't have to do it by all means, however it is a good opportunity
     to show how you can sort the contents in the Content Table
     *)

    SortOrderSet.cSorts := 1;
    SortOrderSet.cCategories := 0;
    SortOrderSet.cExpanded := 0;
    SortOrderSet.aSort[0].ulPropTag := PR_CLIENT_SUBMIT_TIME;
    SortOrderSet.aSort[0].ulOrder := TABLE_SORT_ASCEND;

    (*
     We will define the features that we would like to know
     about each object in the Content Table.
     These will be: Do they have an attachment, the subject, e-mail size and time of receipt.
     *)

    hr := SizedSPropTagArray([PR_HASATTACH, PR_SUBJECT, PR_MESSAGE_SIZE, PR_MESSAGE_DELIVERY_TIME], ContentTablePropTagArray);

    if Failed(hr) then
    begin
      ShowMessage('MAPI Error');
      exit;
    end;

    hr := MAPIFolder.GetContentsTable(0, ContentTable);
    if Failed(hr) then
    begin
      ShowMessage(GETMAPIError(MAPIFolder, hr));
      exit;
    end;

    (*
     We will restrict the number of returned columns
     *)
    hr := ContentTable.SetColumns(ContentTablePropTagArray, 0);
    if Failed(hr) then
    begin
      ShowMessage(GETMAPIError(ContentTable, hr));
      exit;
    end;

    (*
     Freeing memory
     *)
    MAPIFreeBuffer(ContentTablePropTagArray);
    ContentTablePropTagArray := nil;

    hr := ContentTable.SortTable(@SortOrderSet, 0);
    if Failed(hr) then
    begin
      ShowMessage(GETMAPIError(ContentTable, hr));
      exit;
    end;

    ContentTableRowCount := 0;

    hr := ContentTable.GetRowCount(0, ContentTableRowCount);
    if Failed(hr) then
    begin
      ShowMessage(GETMAPIError(ContentTable, hr));
      exit;
    end;

    (*
     A little bit of "make-up".
     We will visualize the contents rendering of the Content Table
     using  Progres Bar
     *)

    ProgresBar := TProgressBar.Create(Self);
    ProgresBar.Max := ContentTableRowCount;
    ProgresBar.Step := 1;
    ProgresBar.Parent := StatusBar1;
    ProgresBar.Left := StatusBar1.Left + 3;
    ProgresBar.Top := 3;
    ProgresBar.Height := StatusBar1.Height - 4;
    ProgresBar.Width := 300;

    while True do
    begin
      ContentTableRows := nil;
      hr := ContentTable.QueryRows(25, 0, ContentTableRows);
      if Failed(hr) then
      begin
        ShowMessage(GETMAPIError(ContentTable, hr));
        exit;
      end;

      if Assigned(ContentTableRows) then
        if ContentTableRows.cRows < 1 then
        begin
          FreePRows(ContentTableRows);
          ContentTableRows := nil;
          break;
        end
        else
        begin
          for iCount := 0 to ContentTableRows.cRows - 1 do
          begin
            Application.ProcessMessages;
            ProgresBar.StepIt;

            (*
             Since we require several properties per object,
             we will use a structure of our own to store them in.
             In this structure we will store each object in a TList
             rather than putting it in TListView
             We will use the OnData event of the TlistView to take this structure
             from our TList in order to visualize it.
             In other words, we will implement Virtual ListView
             *)

            (*
             Allocating memory for our structure
             *)

            GetMem(MessageProperty, SizeOf(TMessageProperties));

            if (PSPropValueArray(ContentTableRows.aRow[iCount].lpProps)[0].ulPropTag = PR_HASATTACH) then
              MessageProperty^.HASATTACH := PSPropValueArray(ContentTableRows.aRow[iCount].lpProps)[0].Value.B;

            MessageProperty^.SUBJECT := nil;

            if (PSPropValueArray(ContentTableRows.aRow[iCount].lpProps)[1].ulPropTag = PR_SUBJECT) then
              if Assigned(PSPropValueArray(ContentTableRows.aRow[iCount].lpProps)[1].Value.lpsz) then
              begin
                GetMem(MessageProperty^.SUBJECT, StrLen(PSPropValueArray(ContentTableRows.aRow[iCount].lpProps)[1].Value.lpsz) * SizeOf(Char) + 1);
                StrCopy(MessageProperty^.SUBJECT, PSPropValueArray(ContentTableRows.aRow[iCount].lpProps)[1].Value.lpsz);
              end;

            if (PSPropValueArray(ContentTableRows.aRow[iCount].lpProps)[2].ulPropTag = PR_MESSAGE_SIZE) then
            begin
              MessageProperty^.MESSAGE_SIZE := ConvertMAPIPropValueToVariant(@PSPropValueArray(ContentTableRows.aRow[iCount].lpProps)[2]);
              MessageSizeCount := MessageSizeCount + MessageProperty^.MESSAGE_SIZE;
            end;

            if (PSPropValueArray(ContentTableRows.aRow[iCount].lpProps)[3].ulPropTag = PR_MESSAGE_DELIVERY_TIME) then
              MessageProperty^.CLIENT_SUBMIT_TIME := ConvertMAPIPropValueToVariant(@PSPropValueArray(ContentTableRows.aRow[iCount].lpProps)[3])
            else
              MessageProperty^.CLIENT_SUBMIT_TIME := 0;

            FFolderListMessages.Add(MessageProperty);
          end; // for iCount:=0

          if Assigned(ContentTableRows) then
            FreePRows(ContentTableRows);
          ContentTableRows := nil;
        end; // if Assigned(ContentTableRows) and  ContentTableRows.cRows<1
    end;

    ContentTable := nil;
    MAPIFolder := nil;

    if Assigned(ProgresBar) then
      ProgresBar.Free;
    ProgresBar := nil;

    StatusBar1.Panels.Add;
    StatusBar1.Panels.Add;
    StatusBar1.Panels[0].Style := psText;
    StatusBar1.Panels[0].Text := IntToStr(ContentTableRowCount) + ' Messages';
    StatusBar1.Panels[0].Width := 130;
    StatusBar1.Panels[1].Style := psText;
    StatusBar1.Panels[1].Text := 'Total used size: ' + FormatFloat('###' + ThousandSeparator + '###' + ThousandSeparator + '##0', (MessageSizeCount div 1024))
      + ' K';

    Application.ProcessMessages;
    lvMailbox.Items.Count := FFolderListMessages.Count;
    lvMailbox.Repaint;
    Application.ProcessMessages;
  except
    if Assigned(ProgresBar) then
      ProgresBar.Free;
    StatusBar1.Panels.Add;
    StatusBar1.Panels.Add;
    StatusBar1.Panels[0].Style := psText;
    StatusBar1.Panels[0].Text := IntToStr(ContentTableRowCount) + ' Messages';
    StatusBar1.Panels[0].Width := 130;
    StatusBar1.Panels[1].Style := psText;
    StatusBar1.Panels[1].Text := 'Total used size: ' + FormatFloat('###' + ThousandSeparator + '###' + ThousandSeparator + '##0', (MessageSizeCount div 1024))
      + ' K';
    lvMailbox.Items.Count := FFolderListMessages.Count;
  end;

  lvMailbox.Items.Count := FFolderListMessages.Count;
  lvMailbox.Items.EndUpdate;
  lvMailbox.Repaint;

end;

function TfrmMain.ShellItem(Index: integer): PMessageProperties;
begin
  Result := PMessageProperties(FFolderListMessages.Items[Index]);
end;

procedure TfrmMain.lvMailboxData(Sender: TObject; Item: TListItem);
begin
  if FFolderListMessages.Count = 0 then
    exit;
  if (Item.Index > FFolderListMessages.Count) then
    exit;

  with ShellItem(Item.Index)^ do
  begin
    try
      if HASATTACH then
        Item.ImageIndex := 8;
      Item.SubItems.Add(StrPas(SUBJECT));
      if ((MESSAGE_SIZE div 1024) > 0) then
        Item.SubItems.Add(FormatFloat('###' + ThousandSeparator + '###' + ThousandSeparator + '##0', (MESSAGE_SIZE div 1024)) + 'K')
      else
        Item.SubItems.Add(IntToStr(1) + 'K');
      Item.SubItems.Add(VarToStr(CLIENT_SUBMIT_TIME));
    except
    end;
  end;
end;

function CustomSortProc(Item1, Item2: Pointer): integer;
var
  Y, Z: integer;
begin
  case ColumnToSort of
    0:
      begin
        if PMessageProperties(Item1)^.HASATTACH then
          Y := 1
        else
          Y := 0;
        if PMessageProperties(Item2)^.HASATTACH then
          Z := 1
        else
          Z := 0;
        Result := -(Y - Z);
      end;

    1:
      Result := CompareText(PMessageProperties(Item1)^.SUBJECT, PMessageProperties(Item2)^.SUBJECT);
    2:
      Result := PMessageProperties(Item1)^.MESSAGE_SIZE - PMessageProperties(Item2)^.MESSAGE_SIZE;
    3:
      Result := CompareDateTime(PMessageProperties(Item1)^.CLIENT_SUBMIT_TIME, PMessageProperties(Item2)^.CLIENT_SUBMIT_TIME);
  else
    Result := 0;
  end;
end;

procedure TfrmMain.lvMailboxColumnClick(Sender: TObject; Column: TListColumn);
begin
  ColumnToSort := Column.Index;
  if (ColumnToSort in [0 .. 3]) then
    FFolderListMessages.Sort(CustomSortProc);
  lvMailbox.Repaint;
end;

end.