Development

unit MainUnit;

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

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

type
  TfrmMain = class(TForm)
    plTOP: TPanel;
    btLogOn: TSpeedButton;
    btLogOff: TSpeedButton;
    rgProfile: TRadioGroup;
    TreeViewGAL: TTreeView;
    Panel1: TPanel;
    ImageList: TImageList;
    lbUsers: TLabel;
    lbUserCount: TLabel;
    ProgressBar: TProgressBar;
    btStop: TButton;
    Label1: TLabel;
    ExportedLabel: TLabel;
    rgGAL: TRadioGroup;
    procedure btLogOnClick(Sender: TObject);
    procedure btLogOffClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure TreeViewGALClick(Sender: TObject);
    procedure btStopClick(Sender: TObject);
    procedure rgGALClick(Sender: TObject);
  private
    { Private declarations }
    FMapiSession: IMAPISession;
    FAddressBook: IAddrBook;
    FGAL: IABContainer;
    FDefaultDir: IABContainer;
    FContentsTable: IMAPITable;
    hr: HRESULT;
    FStopExport: Boolean;
    procedure InitializeMAPI;
    procedure MAPILocalInit(Flag: cardinal);
    procedure MapiInternalLogOff;
    procedure GetExchangeAddressBook;
    procedure GetContainer(const ABContainer: IABContainer);
    procedure GetDefaultABContainer;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation
uses
{$IFDEF DELPHI2011XE2}
  UITypes,
{$ENDIF}
  SysUtils, Windows, Dialogs, EDK, MAPIUtils;
{$R *.DFM}

procedure TfrmMain.InitializeMAPI;
var
  MAPIINIT: TMAPIINIT; // MAPI Init Structure
  QMess: string;
begin
  FContentsTable := nil;
  FGAL := nil;
  FAddressBook := nil;
  FMapiSession := nil;
  FDefaultDir := nil;

  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:
        QMess := 'Invalid parameter or flag!';
      MAPI_E_TOO_COMPLEX:
        QMess := 'The keys required by MAPI could not be initialized.';
      MAPI_E_VERSION:
        QMess := 'The version of OLE installed on the workstation is not compatible with this version of MAPI.';
      MAPI_E_SESSION_LIMIT:
        QMess := '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:
        QMess := 'Not enough system resources were available to complete the operation.';
      MAPI_E_INVALID_OBJECT:
        QMess := 'May fail if system resources are exhausted.';
      MAPI_E_NOT_INITIALIZED:
        QMess := 'The MAPI profile provider has encountered an error.';
    else
      QMess := 'The MAPI Error!'
    end;
    raise Exception.Create(WrapText(QMess, 80));
  end;
end;

procedure TfrmMain.MAPILocalInit(Flag: cardinal);
begin
  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;

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

  (*
    We will check whether there is an interface to the MAPI Session object
    and if it is valid, we will try to get Exchange Address Book.
    We will use one of our auxiliary function that we have named GetExchangeAddressBook
  *)

  btStop.Enabled := btLogOff.Enabled;

  if Assigned(FMapiSession) then
    case rgGAL.ItemIndex of
      0:
        GetExchangeAddressBook;
      1:
        GetDefaultABContainer;
    end;
  btStop.Enabled := False;
end;

procedure TfrmMain.MapiInternalLogOff;
begin
  lbUserCount.Caption := '0';
  ProgressBar.Position := 0;
  ExportedLabel.Caption := '0';

  ClearTTree(TreeViewGAL);

  if Assigned(FContentsTable) then
    FContentsTable := nil;
  if Assigned(FGAL) then
    FGAL := nil;
  if Assigned(FDefaultDir) then
    FDefaultDir := nil;
  if Assigned(FAddressBook) then
    FAddressBook := nil;

  if Assigned(FMapiSession) then
  begin
    FMapiSession.Logoff(Application.Handle, MAPI_LOGOFF_UI, 0);
    FMapiSession := nil;
  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;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  InitializeMAPI;
{$IF DEFINED (WIN64)}
  Self.Caption := Self.Caption + ' - WIN64';
{$ELSE}
  Self.Caption := Self.Caption + ' - WIN32';
{$IFEND}
end;

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

procedure TfrmMain.GetDefaultABContainer;
var
  ObjectType, CbENTRYID: ULONG; // Count of PENTRYID;
  ENTRYID: PENTRYID; // Pointer to ENTRYID of AddressBook
begin
  // see  procedure GetExchangeAddressBook below for comments;
  CbENTRYID := 0;
  ENTRYID := nil;
  hr := 0;
  try
    if not Assigned(FAddressBook) then
    begin
      hr := FMapiSession.OpenAddressBook(0, nil, 0 { AB_NO_DIALOG } , FAddressBook);
      if failed(hr) then
      begin
        ShowMessage(GetMAPIError(FMapiSession, hr));
        Exit;
      end;
    end;
    // The IAddrBook.GetDefaultDir method returns the entry identifier
    // for the address book container that is initially made available.

    if not Assigned(FDefaultDir) then
    begin
      hr := FAddressBook.GetDefaultDir(CbENTRYID, ENTRYID);
      if failed(hr) then
      begin
        ShowMessage(GetMAPIError(FAddressBook, hr));
        Exit;
      end;

      hr := FAddressBook.OpenEntry(CbENTRYID, ENTRYID, @IID_IABContainer, MAPI_BEST_ACCESS or MAPI_NO_CACHE, ObjectType,
        IUnknown(FDefaultDir));

      if (hr = MAPI_E_UNKNOWN_FLAGS) or (MAPI_E_FAILONEPROVIDER = hr) then
        hr := FAddressBook.OpenEntry(CbENTRYID, ENTRYID, @IID_IABContainer, MAPI_BEST_ACCESS, ObjectType, IUnknown(FDefaultDir));

      if ((failed(hr)) or (ObjectType <> MAPI_ABCONT) or (FDefaultDir = nil)) then
        if failed(hr) then
        begin
          ShowMessage(GetMAPIError(FAddressBook, hr));
          ShowMessage('The Default AB Container is NOT available!');
          Exit;
        end
        else
        begin
          ShowMessage('The Default AB Container is NOT available!');
          Exit;
        end;
    end;

  finally
    if Assigned(ENTRYID) then
      MAPIFreeBuffer(ENTRYID);
    if Assigned(FDefaultDir) and Succeeded(hr) then
      GetContainer(FDefaultDir);
  end;

end;

procedure TfrmMain.GetExchangeAddressBook;
var
  ObjectType, CbENTRYID: ULONG; // Count of PENTRYID;
  ENTRYID: PENTRYID; // Pointer to ENTRYID of Exchange GAL
begin
  CbENTRYID := 0;
  ENTRYID := nil;

  hr := 0;

  try

    if not Assigned(FAddressBook) then
    begin
      hr := FMapiSession.OpenAddressBook(0, nil, 0 { AB_NO_DIALOG } , FAddressBook);
      if failed(hr) then
      begin
        ShowMessage(GetMAPIError(FMapiSession, hr));
        Exit;
      end;
    end;

    (*
      function HrFindExchangeGlobalAddressList
      Returns the entry identifier (ENTRYID) of the global address list (GAL) container
      in the address book. The MAPI OpenEntry method is then used to open the GAL.

      This function is part of EDK (Microsoft� Exchange Server Software Development Kit)
      that we have provided here for you.
    *)

    if not Assigned(FGAL) then
    begin
      hr := HrFindExchangeGlobalAddressList(FAddressBook, CbENTRYID, ENTRYID);

      (*
        If the execution of this function results in an error or due to some reason
        the number of bytes in ENTRYID is zero, or ENTRYID is nil, we will show
        that there is an error and will stop the code execution.
      *)

      if failed(hr) or (CbENTRYID = 0) or not Assigned(ENTRYID) then
        if failed(hr) then
        begin
          ShowMessage(GetMAPIError(FAddressBook, hr));
          ShowMessage('The GAL (Global Address List) is NOT available!');
          Exit;
        end
        else
        begin
          ShowMessage('The GAL (Global Address List) is NOT available!');
          Exit;
        end;

      FGAL := nil;
      ObjectType := 0;

      (* Having gotten up to here means that we have a valid ENTRYID,
        and now we will make the AddressBook provide an interface to it.

        The IAddrBook.OpenEntry method opens an address book entry
        and returns a pointer to an interface that can be used
        to access the entry.
      *)

      hr := FAddressBook.OpenEntry(CbENTRYID, ENTRYID, @IID_IABContainer, MAPI_BEST_ACCESS or MAPI_NO_CACHE, ObjectType, IUnknown(FGAL));

      if (hr = MAPI_E_UNKNOWN_FLAGS) or (MAPI_E_FAILONEPROVIDER = hr) then
        hr := FAddressBook.OpenEntry(CbENTRYID, ENTRYID, @IID_IABContainer, MAPI_BEST_ACCESS, ObjectType, IUnknown(FGAL));

      if ((failed(hr)) or (ObjectType <> MAPI_ABCONT) or (FGAL = nil)) then
        if failed(hr) then
        begin
          ShowMessage(GetMAPIError(FAddressBook, hr));
          ShowMessage('The GAL (Global Address List) is NOT available!');
          Exit;
        end
        else
        begin
          ShowMessage('The GAL (Global Address List) is NOT available!');
          Exit;
        end;
    end;

  finally
    (*
      If you have reviewed the HrFindExchangeGlobalAddressList function,
      then you must have noticed that there the MAPIAllocateBuffer function is used
      to get part of the memory where to copy the ENTRYID.
      To avoid any Memory Leak, we should free the occupied memory through MAPIFreeBuffer.
    *)

    if Assigned(ENTRYID) then
      MAPIFreeBuffer(ENTRYID);

    (*
      In case we have been provided with an interface to Exchange Global Address Book,
      we will take GAL Content Table.
      This read-only table contains all e-mail users and their properties such as
      e-mail address, user type - Mail user, DL, etc.
    *)

    if Assigned(FGAL) and Succeeded(hr) then
      GetContainer(FGAL);
  end;
end;

procedure TfrmMain.GetContainer(const ABContainer: IABContainer);
var
  TagArray: PSPropTagArray; // Pointer to an array of property tags identifying
  // properties to be included
  iCount: integer; // Counter
  cRows: ULONG; // Number of rows

  FContentsTablePSRowSet: PSRowSet;
  // Pointer to an SRowSet structure holding the table rows
  UserName: string; // Hold PR_DISPLAY_NAME value
  UserAddress: PChar; // Hold E-MAIL Address
  GALTreeNode: TTreeNode; // Root Node
  UserNode: TTreeNode; // User Node
  DisplayType: integer;
  cbProp: ULONG;
  Prop: Pointer;
  ContainerName: String;
  ContainerDisplayType: ULONG;
  errCount: integer;
begin
  Assert(Assigned(ABContainer));

  TagArray := nil;
  Prop := nil;

  FContentsTablePSRowSet := nil;
  (*
    The IMAPIContainer.GetContentsTable method returns a pointer
    to the container's contents table.

    Parameters
    Flags - [in] Bitmask of flags that controls how the contents table is returned. The following flags can be set:
    MAPI_ASSOCIATED - The container's associated contents table should be returned rather than the standard contents table. This flag is used only with folders. The messages that are included in the associated contents table were created with the MAPI_ASSOCIATED flag set in the call to IMAPIFolder::CreateMessage. Clients typically use the associated contents table to retrieve forms and views.
    MAPI_DEFERRED_ERRORS - GetContentsTable can return successfully, possibly before the table is made accessible to the caller. If the table is not accessible, making a subsequent table call can result in an error.
    MAPI_UNICODE - Requests that the columns containing string data be returned in the Unicode format. If the MAPI_UNICODE flag is not set, the strings should be returned in the ANSI format.
    Table - [out] Pointer to a pointer to the contents table.
  *)

  FContentsTable := nil;
  GALTreeNode := nil;
  TreeViewGAL.Items.BeginUpdate;

  try
    hr := ABContainer.GetContentsTable(0, FContentsTable);
    if failed(hr) then
    begin
      ShowMessage(GetMAPIError(FGAL, hr));
      Exit;
    end;

    // Get Container name
    hr := HrMAPIGetPropString(ABContainer, PR_DISPLAY_NAME, cbProp, Prop);
    if not failed(hr) and (cbProp > 0) then
    begin
      ContainerName := PChar(Prop);
      MAPIFreeBuffer(Prop);
    end
    else
      ContainerName := 'Unknown AB Container';

    // Get Container type
    hr := HrMAPIGetPropLong(ABContainer, PR_DISPLAY_TYPE, ContainerDisplayType);
    if failed(hr) then
      ContainerDisplayType := DT_NOT_SPECIFIC;

    (* Messaging users and distribution lists have a set of five properties
      that are known as the base address properties.
      These are required properties and are briefly described as follows.

      PR_ADDRTYPE  -  Type of address for the recipient.
      Each address type follows a particular format and is used with
      a particular messaging system.
      PR_DISPLAY_NAME - Displayable name for the recipient.
      PR_EMAIL_ADDRESS - Address of the recipient.
      PR_ENTRYID       - Entry identifier used to access the recipient.
      PR_SEARCH_KEY    - Binary comparable key used to identify the recipient.



      We allocate buffer for user properties
      We will get only 3 properties
      - PR_DISPLAY_NAME
      - E-mail Address ($39FE001E)
      - PR_DISPLAY_TYPE (Mailbox, Distribution List,Remoute)
    *)

    hr := MAPIAllocateBuffer(SizeOf(TSPropTagArray) + SizeOf(ULONG) * 2, Pointer(TagArray));

    if failed(hr) then
      Exit;

    TagArray.cValues := 3;
    TagArray.aulPropTag[TagArray.cValues - 3] := PR_DISPLAY_NAME;

    if ContainerDisplayType = DT_GLOBAL then
      TagArray.aulPropTag[TagArray.cValues - 2] := PR_SMTP_ADDRESS
    else
      TagArray.aulPropTag[TagArray.cValues - 2] := PR_EMAIL_ADDRESS;

    TagArray.aulPropTag[TagArray.cValues - 1] := PR_DISPLAY_TYPE;

    (*
      The IMAPITable.GetRowCount method returns the total number
      of rows in the table.

      Parameters
      Flags - Reserved; must be zero.
      Count - [out] The number of rows in the table.
    *)

    errCount := 0;
    hr := FContentsTable.GetRowCount(0, cRows);

    while (hr = MAPI_E_END_OF_SESSION) and (errCount < 5) do
    begin
      hr := FContentsTable.GetRowCount(0, cRows);
      Inc(errCount);
    end;

    if failed(hr) then
    begin
      cRows := 0;
      ShowMessage(GetMAPIError(FContentsTable, hr));
      Exit;
    end;

    (*
      The IMAPITable.SetColumns method defines the particular properties
      and order of properties to appear as columns in the table.

      Parameters
      PropTagArray - [in] Pointer to an array of property tags identifying properties to be included as columns in the table. The property type portion of each tag can be set to a valid type or to PR_NULL to reserve space for subsequent additions. The lpPropTagArray parameter cannot be set to NULL; every table must have at least one column.
      Flags - [in] Bitmask of flags that controls the return of an asynchronous call to SetColumns, for example when SetColumns is used in notification. The following flags can be set:
      TBL_ASYNC - Requests that the column setting operation be performed asynchronously causing SetColumns to potentially return before the operation has fully completed.
      TBL_BATCH - Permits the table to postpone the column setting operation until the data is actually required.
    *)

    hr := FContentsTable.SetColumns(TagArray, TBL_BATCH);
    if failed(hr) then
    begin
      ShowMessage(GetMAPIError(FContentsTable, hr));
      Exit;
    end;

    lbUserCount.Caption := IntToStr(cRows);

    ProgressBar.Max := cRows;
    FStopExport := False;

    ClearTTree(TreeViewGAL);

    GALTreeNode := TreeViewGAL.Items.AddFirst(nil, ContainerName);
    GALTreeNode.ImageIndex := 0;
    GALTreeNode.SelectedIndex := 0;
    GALTreeNode.StateIndex := 0;

    cRows := 0;

    while True do
    begin
      FContentsTablePSRowSet := nil;
 
      // We will Query Table by 25 records
      errCount := 0;
      hr := FContentsTable.QueryRows(25, 0, FContentsTablePSRowSet);
      while (hr = MAPI_E_END_OF_SESSION) and (errCount < 5) do
      begin
        hr := FContentsTable.QueryRows(25, 0, FContentsTablePSRowSet);
        Inc(errCount);
      end;

      // ProgressBar.Max:=ProgressBar.Max+25;

      if failed(hr) then
      begin
        ShowMessage(GetMAPIError(FContentsTable, hr));
        Exit;
      end;

      if not Assigned(FContentsTablePSRowSet) then
        break;

      if Assigned(FContentsTablePSRowSet) then
      begin
        if FContentsTablePSRowSet.cRows = 0 then
        begin
           FreePRows(FContentsTablePSRowSet);
           FContentsTablePSRowSet := nil;
          break;
        end
        else
        begin
          for iCount := 0 to FContentsTablePSRowSet.cRows - 1 do
          begin

            Application.ProcessMessages;

            if FStopExport then
            begin
              Inc(cRows, iCount);
              TreeViewGAL.Items.EndUpdate;
              Exit;
            end;

            Inc(cRows);
            UserName := 'Unknown';
            DisplayType := -1;


            (*
              We will use the value of PR_DISPLAY_NAME as a Text property for the TTreeNode object
              that will be an entry from the table
            *)
            if PSPropValuearray(FContentsTablePSRowSet.aRow[iCount].lpProps)[0].ulPropTag = PR_DISPLAY_NAME then
              UserName := PSPropValuearray(FContentsTablePSRowSet.aRow[iCount].lpProps)[0].Value.lpsz;

            (*
              We will use the value of  PR_SMTP_ADDRESS or PR_EMAIL_ADDRESS as a Hint property for
              the  TTreeNode object that will show us the e-mail address
            *)

            if PSPropValuearray(FContentsTablePSRowSet.aRow[iCount].lpProps)[TagArray.cValues - 2].ulPropTag = TagArray.aulPropTag
              [TagArray.cValues - 2] then
            begin
              GetMem(UserAddress, StrLen(PSPropValuearray(FContentsTablePSRowSet.aRow[iCount].lpProps)[TagArray.cValues - 2].Value.lpsz) *
                SizeOf(Char) + 1);
              StrCopy(UserAddress, PSPropValuearray(FContentsTablePSRowSet.aRow[iCount].lpProps)[TagArray.cValues - 2].Value.lpsz);

              UserName := UserName + ' - ' + StrPas(UserAddress);
            end
            else
              UserAddress := nil;

            (*
              Each entry in this Contents is a certain mail user.
              They may be different from Mail user.
              E.g. distribution list, Public folder to which you send letters,
              automated agent and many other. You can find the full list in MSDN.

              Using the PR_DISPLAY_TYPE value we will be able to visualize
              the objects in different ways.
              For each object type we will use a different icon for TTreeNode
            *)

            if PSPropValuearray(FContentsTablePSRowSet.aRow[iCount].lpProps)[TagArray.cValues - 1].ulPropTag = PR_DISPLAY_TYPE then
              case PSPropValuearray(FContentsTablePSRowSet.aRow[iCount].lpProps)[TagArray.cValues - 1].Value.l of
                DT_MAILUSER:
                  DisplayType := 1;
                DT_DISTLIST, DT_PRIVATE_DISTLIST:
                  DisplayType := 2;
                DT_REMOTE_MAILUSER:
                  DisplayType := 3;
                DT_FORUM:
                  DisplayType := 4;
                DT_AGENT:
                  DisplayType := 5;
              end;

            UserNode := TreeViewGAL.Items.AddChildObject(GALTreeNode, UserName, Pointer(UserAddress));
            UserNode.ImageIndex := DisplayType;
            UserNode.SelectedIndex := DisplayType;
            ProgressBar.StepIt;
          end;

          ExportedLabel.Caption := IntToStr(cRows);

          (*
            We should not forget to free the memory of the returned RowSet
          *)
          if Assigned(FContentsTablePSRowSet) then
          begin
            FreePRows(FContentsTablePSRowSet);
            FContentsTablePSRowSet := nil;
          end;
        end
      end

    end;
  finally
    if Assigned(FContentsTablePSRowSet) then
    begin
      FreePRows(FContentsTablePSRowSet);
      FContentsTablePSRowSet := nil;
    end;

    if Assigned(TagArray) then
      MAPIFreeBuffer(TagArray);
    ProgressBar.Position := 0;
    ExportedLabel.Caption := IntToStr(cRows);
    TreeViewGAL.Items.EndUpdate;
    if Assigned(GALTreeNode) then
      GALTreeNode.Expand(True);
  end;
end;

procedure TfrmMain.TreeViewGALClick(Sender: TObject);
begin
  if Assigned(TreeViewGAL.Selected) then
    if Assigned(TreeViewGAL.Selected.Data) then
      TreeViewGAL.Hint := StrPas(PChar(TreeViewGAL.Selected.Data))
    else
      TreeViewGAL.Hint := 'Unknown Email Address';
end;

procedure TfrmMain.btStopClick(Sender: TObject);
begin
  FStopExport := True;
end;

procedure TfrmMain.rgGALClick(Sender: TObject);
begin
  if Assigned(FMapiSession) then
    case rgGAL.ItemIndex of
      0:
        GetExchangeAddressBook;
      1:
        GetDefaultABContainer;
    end;
end;

end.