Development

(*  This example (By Request #9) will show you how to get access to public folders

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

  This example requires connection to Microsoft Exchange Server for efficient implementation.
*)
unit unMain;

interface

{ Please add "..\Library" to project search path }

{$I IMI.INC}

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

type

  PUserMessage = ^TUserMessage;

  TUserMessage = record
    PR_HASATTACH: boolean;
    PR_SUBJECT: PChar;
    PR_MESSAGE_SIZE: ULONG;
    PR_CLIENT_SUBMIT_TIME: TDateTime;
    PR_ENTRYID: PSBinary;
    PR_MESSAGE_FLAGS: longint;
  end;

type
  TfrmMAIN = class(TForm)
    plTOP: TPanel;
    btLogOn: TSpeedButton;
    btLogOff: TSpeedButton;
    rgProfile: TRadioGroup;
    twMailbox: TTreeView;
    StatusBar1: TStatusBar;
    lvMailbox: TListView;
    Splitter1: TSplitter;
    ilMailboxes: TImageList;
    procedure btLogOnClick(Sender: TObject);
    procedure btLogOffClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure twMailboxClick(Sender: TObject);
    procedure lvMailboxColumnClick(Sender: TObject; Column: TListColumn);
    procedure lvMailboxData(Sender: TObject; Item: TListItem);
    procedure lvMailboxGetSubItemImage(Sender: TObject; Item: TListItem;
      SubItem: integer; var ImageIndex: integer);
    procedure lvMailboxDblClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure MAPILocalInit(Flag: cardinal);
    procedure MapiInternalLogOff;
    procedure OpenPublicInformationStore;
    procedure EnumFolders(ParentFolder: IMAPIFolder; Node: TTreeNode);
    procedure EnumThisFolder(Value: PSBinary);
    procedure OpenMessageModal(MessageEID: PSBinary);
    function ShellItem(Index: integer): PUserMessage;
  public
    { Public declarations }
  end;

var
  frmMAIN: TfrmMAIN;

implementation

uses
{$IFDEF DELPHI2011XE2}
UITypes,
{$ENDIF}
SysUtils, Variants, DateUtils, ComObj, EDK, MAPIMacros, MAPIUtils,
  MAPIVariantProp;
{$R *.dfm}
{$I XE.INC}

var
  FMapiSession: IMAPISession = nil;
  FMDB: IMsgStore = nil;
  hr: HRESULT = 0;
  FRootFolder: IMAPIFolder = nil;
  FNode: TTreeNode = nil;
  FFolderListMess: TList = nil;
  ColumnToSort: integer;
  Reverse: boolean;

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

    1:
      Result := (PUserMessage(Item1)^.PR_MESSAGE_FLAGS and MSGFLAG_READ) - (PUserMessage(Item2)^.PR_MESSAGE_FLAGS and MSGFLAG_READ);
    2:
      Result := CompareText(PUserMessage(Item1)^.PR_SUBJECT, PUserMessage(Item2)^.PR_SUBJECT);
    3:
      Result := PUserMessage(Item1)^.PR_MESSAGE_SIZE - PUserMessage(Item2)^.PR_MESSAGE_SIZE;
    4:
      Result := CompareDateTime(PUserMessage(Item1)^.PR_CLIENT_SUBMIT_TIME, PUserMessage(Item2)^.PR_CLIENT_SUBMIT_TIME);
  else
    Result := 1;
  end;

  if (Reverse) and (ColumnToSort in [0 .. 4]) then
    Result := -Result;
end;

procedure ClearTTree(Value: TTreeView);
var
  iCount: integer;
  p: PSBinary;
begin
  if not Assigned(Value) then
    Exit;
  try
    for iCount := 0 to Value.Items.Count - 1 do
    begin
      p := Value.Items.Item[iCount].Data;
      FreePsBinary(p);
      Value.Items.Item[iCount].Data := nil;
    end;
  finally
    Value.Items.Clear;
  end;
end;

procedure ClearFIMList(Value: TList);
var
  I: integer;
  Va: PUserMessage;
begin
  if not Assigned(Value) then
    Exit;

  try
    for I := 0 to (Value.Count - 1) do
    begin
      Va := Value[I];
      if Assigned(Va.PR_SUBJECT) then
        FreeMem(Va.PR_SUBJECT);
      Va.PR_SUBJECT := nil;
      FreePsBinary(Va.PR_ENTRYID);
      FreeMem(Va);
      Value[I] := nil;
    end;
  finally
    Value.Clear;
  end;
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;
  rgProfile.Enabled := True;
end;

procedure TfrmMAIN.MAPILocalInit(Flag: cardinal);
begin
  ClearTTree(twMailbox);
  try

    hr := MAPILogonEx(Application.Handle,
                      nil,
                      nil,
                      MAPI_EXTENDED or MAPI_NEW_SESSION or MAPI_NO_MAIL or MAPI_ALLOW_OTHERS 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.',
            80), 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.',
            80), mtError, [mbOK], 0);
        MAPI_E_USER_CANCEL:
          ShowMessage
            (WrapText(
            'The user canceled the operation, typically by choosing the Cancel button in a dialog box.',
            80));
        MAPI_E_TOO_MANY_SESSIONS:
          MessageDlg
            (WrapText(
            'The user had too many sessions open simultaneously. No session handle was returned.',
            80), mtError, [mbOK], 0);
        MAPI_E_UNCONFIGURED:
          MessageDlg
            (WrapText(
            'A service provider has not been configured, and therefore the operation did not complete.',
            80), mtError, [mbOK], 0);
      else
        MessageDlg(WrapText('The logon did not succeed', 80), mtError,
          [mbOK], 0);
      end;
      Exit;
    end;

  finally
    btLogOn.Enabled := not Assigned(FMapiSession);
    btLogOff.Enabled := Assigned(FMapiSession);
    rgProfile.Enabled := btLogOn.Enabled;

    if ((btLogOff.Enabled) and Assigned(FMapiSession)) then
      OpenPublicInformationStore;

  end;
end;

procedure TfrmMAIN.MapiInternalLogOff;
var
  Flags: ULONG;
begin
  ClearTTree(twMailbox);
  ClearFIMList(FFolderListMess);

  lvMailbox.Items.Count := 0;
  lvMailbox.Repaint;
  StatusBar1.Panels.Clear;

  Flags := LOGOFF_NO_WAIT;

  if Assigned(FRootFolder) then
    FRootFolder := nil;

  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;
end;

procedure TfrmMAIN.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  MapiInternalLogOff;
  MAPIUninitialize;
end;

procedure TfrmMAIN.FormCreate(Sender: TObject);
var
  ErrorMessage: string;
  MAPIINIT: TMAPIINIT; // MAPI Init Structure
begin
{$IF DEFINED (WIN64)}
  Self.Caption := Self.Caption + ' - WIN64';
{$ELSE}
  Self.Caption := Self.Caption + ' - WIN32';
{$IFEND}
  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:
        ErrorMessage := 'Invalid parameter or flag!';
      MAPI_E_TOO_COMPLEX:
        ErrorMessage := 'The keys required by MAPI could not be initialized.';
      MAPI_E_VERSION:
        ErrorMessage :=
          'The version of OLE installed on the workstation is not compatible with this version of MAPI.';
      MAPI_E_SESSION_LIMIT:
        ErrorMessage := '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:
        ErrorMessage :=
          'Not enough system resources were available to complete the operation.';
      MAPI_E_INVALID_OBJECT:
        ErrorMessage := 'May fail if system resources are exhausted.';
      MAPI_E_NOT_INITIALIZED:
        ErrorMessage := 'The MAPI profile provider has encountered an error.';
    else
      ErrorMessage := 'The MAPI Error!'
    end;
    raise Exception.Create(WrapText(ErrorMessage, 80));
  end;
end;

procedure TfrmMAIN.OpenPublicInformationStore;
var
  Flags: ULONG;
  Node: TTreeNode;
  PropValue: PSPropValue;
  ErrorMessage: string;
begin
  Flags := LOGOFF_NO_WAIT;
  PropValue := nil;

  try
    hr := HrOpenExchangePublicStore(FMapiSession, FMDB);

    if Failed(hr) or not Assigned(FMDB) then
    begin
      // The IMsgStore.StoreLogoff method enables the orderly logoff of the message store.
      if Assigned(FMDB) then
        FMDB.StoreLogoff(Flags);

      ErrorMessage := 'Cannot open "Open Exchange Public Store"';
      ErrorMessage := ErrorMessage + #13#10 + 'Probably your MAPI profile ';
      ErrorMessage := ErrorMessage + 'is not Microsoft Exchange Server related ';
      ErrorMessage := ErrorMessage + 'or you do not have access to Public folders';
      ErrorMessage := ErrorMessage + #13#10 + GetMAPIError(FMDB, hr);
      FMDB := nil;
      ShowMessage(WrapText(ErrorMessage, 80));
      Exit;
    end
    else
    begin
      hr := HrOpenExchangePublicFolders(FMDB, FRootFolder);
      if Failed(hr) then
      begin
        ShowMessage(WrapText('Cannot perform "HrOpenExchangePublicFolders"' +
          CRLF + GetMAPIError(FMDB, hr), 80));
        Exit;
      end;

      hr := HrGetOneProp(FRootFolder, PR_DISPLAY_NAME, PropValue);
      if Failed(hr) or not Assigned(PropValue) then
      begin
        ShowMessage(GetMAPIError(FRootFolder, hr));
        Exit;
      end;

      Node := twMailbox.Items.AddFirst(nil, PropValue.Value.lpsz);
      Node.ImageIndex := 0;
      if Succeeded(hr) then
        EnumFolders(FRootFolder, Node);
    end;
  finally
    if Assigned(PropValue) then
      MapiFreeBuffer(PropValue);
  end;

end;

procedure TfrmMAIN.EnumFolders(ParentFolder: IMAPIFolder; Node: TTreeNode);
var
  Subfolder: IMAPIFolder;
  SubNode: TTreeNode;
  HierarchyTable: IMAPITable;
  ObjType, RowCount: ULONG;
  Count: ULONG;
  RowSet: PSRowSet;
  PropTagArray: PSPropTagArray;
  FolderAsProp: IMAPIProp;
  FolderPropValues: PSPropValue;
  FolderEntryID: PSBinary;
type
  ef = (ePR_DISPLAY_NAME, ePR_ENTRYID, ePR_SUBFOLDERS, ePR_CONTAINER_CLASS, ePR_CONTENT_COUNT);
begin
  if (Assigned(ParentFolder) = False) or (Assigned(Node) = False) then
    Exit;

  HierarchyTable := nil;

  PropTagArray := nil;
  RowSet := nil;
  FolderAsProp := nil;
  FolderPropValues := nil;
  SubNode := nil;

  try
    hr := ParentFolder.GetHierarchyTable(0, HierarchyTable);
    if Failed(hr) then
    begin
      MessageDlg(GetMAPIError(ParentFolder, hr), mtError, [mbOK], 0);
      Exit;
    end;

    hr := HierarchyTable.GetRowCount(0, RowCount);
    if Failed(hr) then
    begin
      MessageDlg(GetMAPIError(HierarchyTable, hr), mtError, [mbOK], 0);
      Exit;
    end;

    if (RowCount < 1) then
      Exit;

    OleCheck(MAPIAllocateBuffer(SizeOf(TSPropTagArray), Pointer(PropTagArray)));

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

    hr := HierarchyTable.SetColumns(PropTagArray, 0);
    if Failed(hr) then
    begin
      MessageDlg(GetMAPIError(HierarchyTable, hr), mtError, [mbOK], 0);
      MapiFreeBuffer(PropTagArray);
      PropTagArray := nil;
      Exit;
    end;

    OleCheck(MapiFreeBuffer(PropTagArray));
    PropTagArray := nil;

    hr := HierarchyTable.QueryRows(RowCount, 0, RowSet);
    if Failed(hr) then
    begin
      MessageDlg(GetMAPIError(HierarchyTable, hr), mtError, [mbOK], 0);
      Exit;
    end;

    if Assigned(RowSet) then
      if RowSet.cRows > 0 then
      begin
        OleCheck(SizedSPropTagArray([PR_DISPLAY_NAME, PR_ENTRYID, PR_SUBFOLDERS,
          PR_CONTAINER_CLASS, PR_CONTENT_COUNT], PropTagArray));

        for Count := 0 to RowSet.cRows - 1 do
        begin
          hr := ParentFolder.OpenEntry(PSPropValueArray(RowSet.aRow[Count].lpProps)[0].Value.bin.cb,
                                       PENTRYID(PSPropValueArray(RowSet.aRow[Count].lpProps)[0].Value.bin.lpb),
                                       nil,
                                       MAPI_BEST_ACCESS or MAPI_DEFERRED_ERRORS,
                                       ObjType,
                                       IUnknown(FolderAsProp));

          if Failed(hr) then
          begin
            MessageDlg(GetMAPIError(ParentFolder, hr), mtError, [mbOK], 0);
            Exit;
          end;

          hr := FolderAsProp.GetProps(PropTagArray, 0, ObjType, FolderPropValues);
          if Failed(hr) then
          begin
            MessageDlg(GetMAPIError(FolderAsProp, hr), mtError, [mbOK], 0);
            Exit;
          end;

          FolderEntryID := nil;

          if MakePSBinary(PSPropValueArray(FolderPropValues)[Ord(ePR_ENTRYID)].Value.bin, FolderEntryID) then
          begin
            SubNode := twMailbox.Items.AddChildObject(Node,
              StrPas(PSPropValueArray(FolderPropValues)[Ord(ePR_DISPLAY_NAME)].Value.lpsz),
              FolderEntryID);

            begin
              if PSPropValueArray(FolderPropValues)[Ord(ePR_CONTAINER_CLASS)].ulPropTag = PR_CONTAINER_CLASS then
                if AnsiSameText(PSPropValueArray(FolderPropValues)[Ord(ePR_CONTAINER_CLASS)].Value.lpsz,
                'IPF.Appointment') then
                  SubNode.ImageIndex := 3
                else if AnsiSameText(PSPropValueArray(FolderPropValues)[Ord(ePR_CONTAINER_CLASS)].Value.lpsz, 'IPF.Contact') then
                  SubNode.ImageIndex := 4
                else if AnsiSameText(PSPropValueArray(FolderPropValues)[Ord(ePR_CONTAINER_CLASS)].Value.lpsz, 'IPF.StickyNote') then
                  SubNode.ImageIndex := 6
                else if AnsiSameText(PSPropValueArray(FolderPropValues)[Ord(ePR_CONTAINER_CLASS)].Value.lpsz, 'IPF.Task') then
                  SubNode.ImageIndex := 7
                else if AnsiSameText(PSPropValueArray(FolderPropValues)[Ord(ePR_CONTAINER_CLASS)].Value.lpsz, 'IPF.Jurnal') or
                  AnsiSameText(PSPropValueArray(FolderPropValues)[Ord(ePR_CONTAINER_CLASS)].Value.lpsz, 'IPF.Journal') then
                  SubNode.ImageIndex := 5
                else if AnsiSameText(PSPropValueArray(FolderPropValues)[Ord(ePR_CONTAINER_CLASS)].Value.lpsz, 'IPF.Note') then
                  SubNode.ImageIndex := 2
                else
                  SubNode.ImageIndex := 1
              else
                SubNode.ImageIndex := 1;
            end;

            SubNode.SelectedIndex := SubNode.ImageIndex;
          end
          else
            Exit;

           if Bool(PSPropValueArray(FolderPropValues)[Ord(ePR_SUBFOLDERS)].Value.B) then
          begin
            hr := ParentFolder.OpenEntry(FolderEntryID.cb, PENTRYID(FolderEntryID.lpb), @IID_IMAPIFolder, MAPI_BEST_ACCESS or
              MAPI_NO_CACHE, ObjType, IUnknown(Subfolder));
            if (hr = MAPI_E_UNKNOWN_FLAGS) or (MAPI_E_FAILONEPROVIDER=hr) then
              hr := ParentFolder.OpenEntry(FolderEntryID.cb, PENTRYID(FolderEntryID.lpb), @IID_IMAPIFolder, MAPI_BEST_ACCESS,
                ObjType, IUnknown(Subfolder));

            if Failed(hr) then
            begin
              MessageDlg(GetMAPIError(ParentFolder, hr), mtError, [mbOK], 0);
              Exit;
            end;

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

          if Assigned(FolderPropValues) then
            MapiFreeBuffer(FolderPropValues);
          FolderPropValues := nil;
          if Assigned(FolderAsProp) then
            FolderAsProp := nil;
        end;
      end;
  finally
    if Assigned(RowSet) then
      FreePRows(RowSet);
    if Assigned(HierarchyTable) then
      HierarchyTable := nil;
    if Assigned(PropTagArray) then
      MapiFreeBuffer(PropTagArray);
    if Assigned(FolderPropValues) then
      MapiFreeBuffer(FolderPropValues);
    if Assigned(FolderAsProp) then
      FolderAsProp := nil;
  end;
end;

procedure TfrmMAIN.twMailboxClick(Sender: TObject);
begin
  if Assigned(twMailbox.Selected) = False then
    Exit;

  if FNode <> twMailbox.Selected then
  begin
    FNode := twMailbox.Selected;
    Self.Enabled := False;
    try
      if Assigned(twMailbox.Selected.Data) then
        EnumThisFolder(twMailbox.Selected.Data);
    finally
      Self.Enabled := True;
    end;
  end;
end;

procedure TfrmMAIN.EnumThisFolder(Value: PSBinary);
var
  ContentTablePropTagArray: PSPropTagArray;
  SortOrderSet: TSSortOrderSet;
  Folder: IMAPIFolder;

  MessageSizeCount, ContentTableRowCount, ObjType: ULONG;
  Table: IMAPITable;
  RowSet: PSRowSet;
  UserMessageProperties: PUserMessage;
  iCount: ULONG;
  ProgresBar: TProgressBar;
type
  pr = (ePR_HASATTACH, ePR_MESSAGE_FLAGS, ePR_SUBJECT, ePR_MESSAGE_SIZE, ePR_MESSAGE_DELIVERY_TIME, ePR_ENTRYID);
begin
  MessageSizeCount := 0;

  Folder := nil;
  Table := nil;
  RowSet := nil;

  ContentTablePropTagArray := nil;

  lvMailbox.Items.BeginUpdate;

  try
    ProgresBar := nil;

    MessageSizeCount := 0;
    StatusBar1.Panels.Clear;

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

    if (hr = MAPI_E_UNKNOWN_FLAGS) or (MAPI_E_FAILONEPROVIDER=hr) then
      hr := FMDB.OpenEntry(Value.cb, PENTRYID(Value.lpb), @IID_IMAPIFolder,
        MAPI_BEST_ACCESS, ObjType, IUnknown(Folder));

    if Failed(hr) then
    begin
      MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0);
      Exit;
    end;

    ClearFIMList(FFolderListMess);

    lvMailbox.Items.Count := 0;
    Application.ProcessMessages;
    lvMailbox.Repaint;
    Application.ProcessMessages;

    OleCheck(SizedSPropTagArray([PR_HASATTACH, PR_MESSAGE_FLAGS, PR_SUBJECT,
      PR_MESSAGE_SIZE, PR_MESSAGE_DELIVERY_TIME, PR_ENTRYID],
      ContentTablePropTagArray));

    hr := Folder.GetContentsTable(0, Table);

    if Failed(hr) then
    begin
      MessageDlg(GetMAPIError(Folder, hr), mtError, [mbOK], 0);
      Exit;
    end;

    hr := Table.SetColumns(ContentTablePropTagArray, 0);

    if Failed(hr) then
    begin
      MessageDlg(GetMAPIError(Table, hr), mtError, [mbOK], 0);
      Exit;
    end;

    OleCheck(MapiFreeBuffer(ContentTablePropTagArray));
    ContentTablePropTagArray := nil;

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

    hr := Table.SortTable(@SortOrderSet, TBL_BATCH);
    if Failed(hr) then
    begin
      MessageDlg(GetMAPIError(Table, hr), mtError, [mbOK], 0);
      Exit;
    end;

    ContentTableRowCount := 0;

    hr := Table.GetRowCount(0, ContentTableRowCount);
    if Failed(hr) then
    begin
      MessageDlg(GetMAPIError(Table, hr), mtError, [mbOK], 0);
      Exit;
    end;

    if ContentTableRowCount > 0 then
    begin
      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
        RowSet := nil;
        hr := Table.QueryRows(25, 0, RowSet);

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

              GetMem(UserMessageProperties, SizeOf(TUserMessage));
              ZeroMemory(UserMessageProperties, SizeOf(TUserMessage));

              if (PSPropValueArray(RowSet.aRow[iCount].lpProps)[Ord(ePR_HASATTACH)].ulPropTag = PR_HASATTACH) then
                UserMessageProperties.PR_HASATTACH := boolean(PSPropValueArray(RowSet.aRow[iCount].lpProps)[Ord(ePR_HASATTACH)].Value.B);

              UserMessageProperties.PR_SUBJECT := nil;

              if (PSPropValueArray(RowSet.aRow[iCount].lpProps)[Ord(ePR_SUBJECT)].ulPropTag = PR_SUBJECT) then
                if Assigned(PSPropValueArray(RowSet.aRow[iCount].lpProps)[Ord(ePR_SUBJECT)].Value.lpsz) then
                begin
                  GetMem(UserMessageProperties.PR_SUBJECT,
                    StrLen(PSPropValueArray(RowSet.aRow[iCount].lpProps)[Ord(ePR_SUBJECT)].Value.lpsz) * SizeOf(Char) + 1);
                  StrCopy(UserMessageProperties.PR_SUBJECT,
                    PSPropValueArray(RowSet.aRow[iCount].lpProps)
                    [Ord(ePR_SUBJECT)].Value.lpsz);
                end;

              if (PSPropValueArray(RowSet.aRow[iCount].lpProps)[Ord(ePR_MESSAGE_SIZE)].ulPropTag = PR_MESSAGE_SIZE) then
              begin
                UserMessageProperties.PR_MESSAGE_SIZE :=
                  PSPropValueArray(RowSet.aRow[iCount].lpProps)[Ord(ePR_MESSAGE_SIZE)].Value.ul;
                MessageSizeCount := MessageSizeCount + UserMessageProperties.PR_MESSAGE_SIZE;
              end;

              if (PSPropValueArray(RowSet.aRow[iCount].lpProps)[Ord(ePR_MESSAGE_DELIVERY_TIME)].ulPropTag = PR_MESSAGE_DELIVERY_TIME) then
                UserMessageProperties.PR_CLIENT_SUBMIT_TIME :=
                ConvertMAPIPropValueToVariant(@PSPropValueArray(RowSet.aRow[iCount].lpProps)[Ord(ePR_MESSAGE_DELIVERY_TIME)]);

              if (PSPropValueArray(RowSet.aRow[iCount].lpProps)[Ord(ePR_ENTRYID)].ulPropTag = PR_ENTRYID) then
                MakePSBinary(PSPropValueArray(RowSet.aRow[iCount].lpProps)[Ord(ePR_ENTRYID)].Value.bin,
                  UserMessageProperties.PR_ENTRYID);

              if (PSPropValueArray(RowSet.aRow[iCount].lpProps)[Ord(ePR_MESSAGE_FLAGS)].ulPropTag = PR_MESSAGE_FLAGS) then
                UserMessageProperties.PR_MESSAGE_FLAGS :=
                PSPropValueArray(RowSet.aRow[iCount].lpProps)[Ord(ePR_MESSAGE_FLAGS)].Value.L;

              FFolderListMess.Add(UserMessageProperties);
            end;

            if Assigned(RowSet) then
              FreePRows(RowSet);
            RowSet := nil;
          end;
      end;
    end;
    Table := nil;
    Folder := nil;

    if Assigned(ProgresBar) then
      FreeAndNil(ProgresBar);

    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 := FFolderListMess.Count;
    lvMailbox.Repaint;
    Application.ProcessMessages;
    ProgresBar := nil;
  finally
    if Assigned(ProgresBar) then
      ProgresBar.Free;
    StatusBar1.Panels.Add;
    StatusBar1.Panels[0].Style := psText;
    StatusBar1.Panels[0].Text := IntToStr(ContentTableRowCount) + ' Messages';
    StatusBar1.Panels[0].Width := 100;
    StatusBar1.Panels[1].Style := psText;
    StatusBar1.Panels[1].Text := 'Total used size: ' +
      FormatFloat('###' + ThousandSeparator + '###' + ThousandSeparator + '##0',
      (MessageSizeCount div 1024)) + ' K';
    StatusBar1.Panels[1].Width := 200;

    lvMailbox.Items.Count := FFolderListMess.Count;

    if Assigned(Table) then
      Table := nil;
    if Assigned(RowSet) then
      FreePRows(RowSet);
    if Assigned(ContentTablePropTagArray) then
      MapiFreeBuffer(ContentTablePropTagArray);

  end;
  lvMailbox.Items.Count := FFolderListMess.Count;
  lvMailbox.Items.EndUpdate;
  lvMailbox.Repaint;
end;

function TfrmMAIN.ShellItem(Index: integer): PUserMessage;
begin
  Result := PUserMessage(FFolderListMess.Items[Index]);
end;

procedure TfrmMAIN.lvMailboxColumnClick(Sender: TObject; Column: TListColumn);
begin
  if Column.Index <> ColumnToSort then
    Reverse := False
  else
    Reverse := not Reverse;

  ColumnToSort := Column.Index;

  if (ColumnToSort in [0 .. 4]) then
    FFolderListMess.Sort(CustomSortProc);

  lvMailbox.Repaint;
end;

procedure TfrmMAIN.lvMailboxData(Sender: TObject; Item: TListItem);
begin
  if FFolderListMess.Count = 0 then
    Exit;
  if (Item.Index > FFolderListMess.Count) then
    Exit;

  with ShellItem(Item.Index)^ do
  begin
    if Assigned(PR_ENTRYID) then
      Item.Data := ShellItem(Item.Index)^.PR_ENTRYID;
    Item.SubItems.Add('');

    if PR_HASATTACH then
      Item.ImageIndex := 8;

    Item.SubItems.Add(StrPas(PR_SUBJECT));

    if ((PR_MESSAGE_SIZE div 1024) > 0) then
      Item.SubItems.Add(FormatFloat('###' + ThousandSeparator + '###' + ThousandSeparator + '##0', (PR_MESSAGE_SIZE div 1024)) + 'K')
    else
      Item.SubItems.Add(IntToStr(1) + 'K');

    try
      Item.SubItems.Add(VarToStr(PR_CLIENT_SUBMIT_TIME));
    except
      Item.SubItems.Add('');
    end;
  end;
end;

procedure TfrmMAIN.lvMailboxGetSubItemImage(Sender: TObject; Item: TListItem; SubItem: integer; var ImageIndex: integer);
begin
  if SubItem = 0 then
    with ShellItem(Item.Index)^ do
      if (PR_MESSAGE_FLAGS and MSGFLAG_READ) <> 0 then
        ImageIndex := 9
      else
        ImageIndex := 10;
end;

procedure TfrmMAIN.OpenMessageModal(MessageEID: PSBinary);
var
  MAPIMessage: IMessage;
  ObjType, ValuesShow: ULONG;
  Token: ULONG_PTR;

  PropTagArrayShowForm: PSPropTagArray;
  PropValueShow: PSPropValue;

  Folder: IMAPIFolder;

  Flags, ACCESS, STATUS: ULONG;
  _CLASS: PAnsiChar;

type
  pr = (eFLAGS, eCLASS, eACCESS, eEID, eSTATUS, ePARENT);
begin
  MAPIMessage := nil;
  PropTagArrayShowForm := nil;
  PropValueShow := nil;
  Folder := nil;
  try

    hr := FMDB.OpenEntry(MessageEID.cb, PENTRYID(MessageEID.lpb), @IID_IMessage,
      MAPI_BEST_ACCESS or MAPI_NO_CACHE, ObjType, IUnknown(MAPIMessage));

    if (hr = MAPI_E_UNKNOWN_FLAGS) or (MAPI_E_FAILONEPROVIDER=hr) then
      hr := FMDB.OpenEntry(MessageEID.cb, PENTRYID(MessageEID.lpb),
        @IID_IMessage, MAPI_BEST_ACCESS, ObjType, IUnknown(MAPIMessage));

    if Failed(hr) then
    begin
      ShowMessage(GetMAPIError(FMDB, hr));
      Exit;
    end;

    hr := SizedSPropTagArray([PR_MESSAGE_FLAGS, PR_MESSAGE_CLASS_A,
      // Always ANSI
      PR_ACCESS, PR_ENTRYID, PR_MSG_STATUS, PR_PARENT_ENTRYID],
      PropTagArrayShowForm);

    if Failed(hr) then
    begin
      ShowMessage('MAPI Memory Error!');
      Exit;
    end;

    // Get required properties from the message
    hr := MAPIMessage.GetProps(PropTagArrayShowForm, // property tag array
      0, // flags
      ValuesShow, // Count of values returned
      PropValueShow); // Values returned
    if Failed(hr) then
    begin
      ShowMessage(GetMAPIError(MAPIMessage, hr));
      Exit;
    end;

    hr := FMDB.OpenEntry(PSPropValueArray(PropValueShow)[Ord(ePARENT)].Value.bin.cb,
          PENTRYID(PSPropValueArray(PropValueShow)[Ord(ePARENT)].Value.bin.lpb),
          nil,
          MAPI_BEST_ACCESS or MAPI_NO_CACHE,
          ObjType,
          IUnknown(Folder));

    if (hr = MAPI_E_UNKNOWN_FLAGS) or (MAPI_E_FAILONEPROVIDER=hr)then
      hr := FMDB.OpenEntry(PSPropValueArray(PropValueShow)[Ord(ePARENT)].Value.bin.cb,
                  PENTRYID(PSPropValueArray(PropValueShow)[Ord(ePARENT)].Value.bin.lpb),
                  nil,
                  MAPI_BEST_ACCESS,
                  ObjType,
                  IUnknown(Folder));

    if Failed(hr) then
    begin
      ShowMessage(GetMAPIError(FMDB, hr));
      Exit;
    end;

    // set up the 'display message' form
    hr := FMapiSession.PrepareForm(nil, // default interface
      MAPIMessage, // message to open
      Token); // basically, the pointer to the form

    if Failed(hr) then
    begin
      ShowMessage(GetMAPIError(FMapiSession, hr));
      Exit;
    end;

    if PSPropValueArray(PropValueShow)[Ord(eFLAGS)].ulPropTag = PR_MESSAGE_FLAGS
    then
      Flags := PSPropValueArray(PropValueShow)[Ord(eFLAGS)].Value.ul
    else
      Flags := 0;

    if PSPropValueArray(PropValueShow)[Ord(eSTATUS)].ulPropTag = PR_MSG_STATUS
    then
      STATUS := PSPropValueArray(PropValueShow)[Ord(eSTATUS)].Value.ul
    else
      STATUS := 0;

    ACCESS := 0;

    if PSPropValueArray(PropValueShow)[Ord(eCLASS)].ulPropTag = PR_MESSAGE_CLASS_A
    then
      _CLASS := PSPropValueArray(PropValueShow)[Ord(eCLASS)].Value.lpszA
    else
      _CLASS := 'IPM.Note';

    hr := FMapiSession.ShowForm(Application.Handle, // parent window
      FMDB, // message store
      Folder, // parent folder
      nil, // default interface
      Token, nil, // reserved
      MAPI_POST_MESSAGE, // 0,  //flags
      STATUS, // message status
      Flags, // message flags
      ACCESS, // access
      _CLASS // message class  -- Always ANSI
      );

    if Failed(hr) and (MAPI_E_USER_CANCEL <> hr) then
    begin
      ShowMessage(GetMAPIError(FMapiSession, hr));
      Exit;
    end;

    hr := MAPIMessage.SetReadFlag(MSGFLAG_READ);
  finally
    if Assigned(PropTagArrayShowForm) then
      MapiFreeBuffer(PropTagArrayShowForm);
    if Assigned(PropValueShow) then
      MapiFreeBuffer(PropValueShow);
    if Assigned(Folder) then
      Folder := nil;
    if Assigned(MAPIMessage) then
      MAPIMessage := nil;
  end;
end;

procedure TfrmMAIN.lvMailboxDblClick(Sender: TObject);
begin
  if (Assigned(lvMailbox.Selected) = False) then
    Exit;
  OpenMessageModal(PSBinary(lvMailbox.Selected.Data));
  FNode := nil;
end;

initialization
  FFolderListMess := TList.Create;

finalization
  ClearFIMList(FFolderListMess);
  FreeAndNil(FFolderListMess);

end.