Copyright © 2025 IMIBO. Privacy Statement
Request # 8
How to use Personal folder (*.PST) files from DELPHI
(Loading and Creating a *.PST)
How with Extended MAPI a developer working on DELPHI can create or/and load a PST file without existing MAPI profile.
Then you can use this *.PST as your Private Store, that hold secret data.
Personal Information Stores – PST files – offers ideal opportunities for storing our correspondence in one place.
This example will illustrate how to create/open PST files.
In addition, we will illustrate how to copy/move/erase messages and folders.
We chose to illustrate this here, since it is assumed that the PST file will not contain significant information and we may fidget with the data.
We will show you how to implement the IMAPIProgress class that MAPI provides for the process visualization.
With it you may, for instance, build an indicator that will show the process of copying 10 000 e-mails from one folder into another. The user will be able to monitor the process and will not be bored – something is „moving“ there 🙂
Also:
- Using IMsgStore
- Using IMsgServiceAdmin
- Using IProfAdmin
- …
Download Request #8 as Compiled Application
Download Project (DELPHI 10.4) ZIP file
Source Code: In package
Code Snippets:
unit uMain; (* Personal Information Stores - PST files - offers ideal opportunities for storing our correspondence in one place. This example will illustrate how to create/ open PST files. In addition, we will illustrate how to copy/ move/ erase messages and folders. We chose to illustrate this here, since it is assumed that the PST file will not contain significant information and we may fidget with the data. We will show you how to implement the IMAPIProgress class that MAPI provides for the process visualization. With it you may, for instance, build an indicator that will show the process of copying 10 000 e-mails from one folder into another. The user will be able to monitor the process and will not be bored - something is "moving" there *) interface { Please add "..\Library" to project search path } {$I IMI.INC} uses Classes, Controls, Dialogs, Forms, Windows, Buttons, ComCtrls, ExtCtrls, ExtendedMAPI, Menus, StdCtrls, ImgList, 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; PR_INSTANCE_KEY: PSBinary; end; TPSTForm = class(TForm) Panel1: TPanel; OpenDialog1: TOpenDialog; ntOpenCreate: TBitBtn; PopupMenu1: TPopupMenu; CreateSubFolder1: TMenuItem; DeleteFolder1: TMenuItem; ilMailboxes: TImageList; ListViewFolder: TListView; StatusBar1: TStatusBar; N1: TMenuItem; EmptyFolder1: TMenuItem; Splitter1: TSplitter; N2: TMenuItem; CopyFolder1: TMenuItem; MoveFolder1: TMenuItem; Panel2: TPanel; Mailbox: TTreeView; Splitter2: TSplitter; lvMailbox: TListView; lvPopMenu: TPopupMenu; CopyMessagesto1: TMenuItem; MoveMessagesto1: TMenuItem; N3: TMenuItem; DeleteMessages1: TMenuItem; N4: TMenuItem; SelectAll1: TMenuItem; btImport: TBitBtn; OpenDialog2: TOpenDialog; procedure ntOpenCreateClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure CreateSubFolder1Click(Sender: TObject); procedure DeleteFolder1Click(Sender: TObject); procedure MailboxClick(Sender: TObject); procedure EmptyFolder1Click(Sender: TObject); procedure CopyFolder1Click(Sender: TObject); procedure MoveFolder1Click(Sender: TObject); procedure lvMailboxData(Sender: TObject; Item: TListItem); procedure lvMailboxGetSubItemImage(Sender: TObject; Item: TListItem; SubItem: Integer; var ImageIndex: Integer); procedure lvMailboxMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure CopyMessagesto1Click(Sender: TObject); procedure MoveMessagesto1Click(Sender: TObject); procedure FormCloseQuery(Sender: TObject; var CanClose: boolean); procedure lvMailboxColumnClick(Sender: TObject; Column: TListColumn); procedure lvMailboxClick(Sender: TObject); procedure DeleteMessages1Click(Sender: TObject); procedure lvMailboxDblClick(Sender: TObject); procedure SelectAll1Click(Sender: TObject); procedure btImportClick(Sender: TObject); private { Private declarations } hr: HRESULT; FCanClose: boolean; FCreate: boolean; FMAPISession: IMAPISession; FMDB: IMsgStore; FFolderMessagesList: TList; FTable: IMAPITable; FSelected: TTreeNode; FRootEID, FInBoxEID, FOutBoxEID, FTrashBoxEID, FSentBoxEID: PSBinary; FProfileName: PAnsiChar; procedure OpenPST; procedure GetFolderRoot(twMailbox: TTreeView); procedure ClearBoxes; procedure ShowMapiProp(cValues: ULONG; PropValues: PSPropValue); function IsSystemFolder(FolderEntryID: PSBinary): boolean; procedure EnumFolders(ParentFolder: IMAPIFolder; Node: TTreeNode; twMailbox: TTreeView); procedure EnumFolder(Folder: IMAPIFolder); procedure LoadMessages(Table: IMAPITable); procedure ClearMessagesList; procedure ClearContentTable; function AddItemToListBox(Lock: Bool; iRow: Integer; RowToAdd: PSRow): int64; function ShellItem(Index: Integer): PUserMessage; procedure UpdatePanels(MessageSizeCount: ULONG); procedure CopyOrMoveMessages(Move: boolean = False); procedure DeleteMessages; procedure FindInboxNode; public { Public declarations } end; var PSTForm: TPSTForm; implementation uses {$IFDEF DELPHI2011XE2} UITypes, {$ENDIF} SysUtils, ComObj, CreateNewPST, EDK, MAPIMacros, MAPIUtils, MAPIVariantProp, NewFolder, unProgress, unCopyMove, ActiveX, DateUtils, Variants, unfrmmessage {$IFDEF DELPHI2012XE4}, AnsiStrings {$ENDIF DELPHI2012XE4}; {$R *.DFM} {$I XE.INC} var ColumnToSort: Integer = 4; Reverse: boolean = False; 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); FreePSBinary(Va^.PR_INSTANCE_KEY); Value[I] := nil; end; finally Value.Clear; end; end; procedure ClearTTree(Value: TTreeView); var iCounter: Integer; Va: PSBinary; begin for iCounter := 0 to Value.Items.Count - 1 do begin if Assigned(Value.Items.Item[iCounter].Data) then begin Va := PSBinary(Value.Items.Item[iCounter].Data); FreePSBinary(Va); end; Value.Items.Item[iCounter].Data := nil; end; Value.Items.Clear; end; function CustomSortProc(Item1, Item2: Pointer): Integer; var Y, Z: Integer; begin try 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; finally end; end; function TPSTForm.ShellItem(Index: Integer): PUserMessage; begin Result := PUserMessage(FFolderMessagesList.Items[Index]); end; procedure TPSTForm.ClearBoxes; begin if Assigned(FRootEID) then MapiFreeBuffer(FRootEID); if Assigned(FInBoxEID) then MapiFreeBuffer(FInBoxEID); if Assigned(FOutBoxEID) then MapiFreeBuffer(FOutBoxEID); if Assigned(FTrashBoxEID) then MapiFreeBuffer(FTrashBoxEID); if Assigned(FSentBoxEID) then MapiFreeBuffer(FSentBoxEID); FRootEID := nil; FInBoxEID := nil; FOutBoxEID := nil; FTrashBoxEID := nil; FSentBoxEID := nil; end; procedure TPSTForm.ntOpenCreateClick(Sender: TObject); var flag: ULONG; DisplayName, Password: PAnsiChar; PersonalStorePath: String; begin btImport.Enabled := False; Password := nil; DisplayName := nil; ClearMessagesList; ClearBoxes; ClearContentTable; ClearTTree(Mailbox); ListViewFolder.Items.BeginUpdate; ListViewFolder.Items.Clear; ListViewFolder.Items.EndUpdate; Application.ProcessMessages; flag := LOGOFF_NO_WAIT; FProfileName := nil; hr := S_OK; try if Assigned(FMDB) then FMDB.StoreLogoff(flag); FMDB := nil; if Assigned(FMAPISession) then FMAPISession.Logoff(Application.Handle, MAPI_LOGOFF_UI, 0); FMAPISession := nil; if OpenDialog1.Execute then PersonalStorePath := OpenDialog1.FileName else exit; flag := PSTF_NO_ENCRYPTION; FCreate := not FileExists(PersonalStorePath); if FCreate then begin CreateNewPSTFile := TCreateNewPSTFile.Create(self); if CreateNewPSTFile.ShowModal = mrOk then begin if Trim(CreateNewPSTFile.ebDispalyName.Text) <> '' then begin GetMem(DisplayName, Length(AnsiString(Trim(CreateNewPSTFile.ebDispalyName.Text))) + 1); {$IFDEF DELPHI2012XE4}AnsiStrings.StrPCopy{$ELSE}StrPCopy{$ENDIF DELPHI2012XE4}(DisplayName, AnsiString(Trim(CreateNewPSTFile.ebDispalyName.Text))); end; if Trim(CreateNewPSTFile.ebPassword.Text) <> '' then begin GetMem(Password, Length(AnsiString(Trim(CreateNewPSTFile.ebPassword.Text))) + 1); {$IFDEF DELPHI2012XE4}AnsiStrings.StrPCopy{$ELSE}StrPCopy{$ENDIF DELPHI2012XE4}(Password, AnsiString(Trim(CreateNewPSTFile.ebPassword.Text))); end else begin GetMem(Password, 1); Password^ := #0; end; // no password case CreateNewPSTFile.RadioGroup1.ItemIndex of 1: flag := PSTF_COMPRESSABLE_ENCRYPTION; 2: flag := PSTF_BEST_ENCRYPTION; end; end; FreeAndNil(CreateNewPSTFile); end else begin GetMem(DisplayName, Length('IMI PRIVATE STORE') + 1); {$IFDEF DELPHI2012XE4}AnsiStrings.StrPCopy{$ELSE}StrPCopy{$ENDIF DELPHI2012XE4}(DisplayName, 'IMI PRIVATE STORE'); end; (* Microsoft Office Outlook 2007 specific Normally, Microsoft Office Outlook 2007 ans above do not use MapiSvc.inf file. More over, if this file exists, the service sections [MSUPST MS] and/or [MSPST MS] can not exist. We will check for existence of these sections, and eventually we will add them *) // if not CheckPstSections then // raise Exception.Create('No PST Providers are avaliable'); (* Creating a PST profile section through CreateMsgService. The creation of the actual PST file is a two step process. First the client should call CreateMsgService to setup the profile section and then ConfigureMsgService to create the PST file. The CreateMsgService call will setup the PR_DISPLAY_NAME property in the profile section to be used on the PST when it is created. Configuring an PST file through ConfigureMsgService. The configuration of an PST can take two forms, either configuring an existing PST or creating a new PST. The Microsoft Personal Information Store provider will try to find the necessary properties by first looking in the array of SPropValue structures provided by the client and then in the profile section, except for PR_PST_PW_SZ_OLD for which it will only look in the array of properties. The Microsoft PST provider will try to open the file specified by the PR_PST_PATH property, using the password given in the PR_PST_PW_SZ_OLD property. If it finds a file and it recognizes it as a PST file, it will start the configuration routine. Otherwise it will start the creation routine. The configuration routine will look for the PR_DISPLAY_NAME_A and PR_COMMENT_A properties and set them in the message store object. Then it will look for the PR_PST_REMEMBER_PW property to decide if it should remember the password in the profile. (If not found then it will defaut to the current status of the profile password.) Then if it is supposed to use UI, it will display the configuration property sheet to the user. After all has succeeded, it will update the profile. The creation routine will follow one of two paths to get the PR_PST_PATH property. If it is supposed to use UI it will always display the file open dialog to confirm the path passed in or allow the user to change it. If the user chooses an existing file and it recognizes it as an PST it will drop back to the configuration routine. If the user chooses an existing file and it is not recognized as an PST file, the user will be given the option of choosing another file or creating a new PST in its place, in which case is will continue with the create routine. If the user chooses a new file it will continue with the create routine. If the routine is not allowed to use UI, then the routine will create a file at the given path even if another file exists there. Once it decides to continue with the creation process it will get the PR_DISPLAY_NAME, PR_COMMENT, PR_PST_ENCRYPTION, and PR_PST_SZ_PW_NEW properties. If it is supposed to use UI, it will use these to initialize the creation dialog and get any changes the user want. Then it will create a new file and update the profile. *) hr := HrCreatePersonalStore(PAnsiChar(AnsiString(PersonalStorePath)), flag, DisplayName, Password, FCreate, FProfileName); if failed(hr) then exit; flag := MAPI_NEW_SESSION or MAPI_EXPLICIT_PROFILE or MAPI_NO_MAIL or MAPI_EXTENDED or MAPI_ALLOW_OTHERS; hr := MAPILogonEx(Application.Handle, PChar(FProfileName), nil, flag, FMAPISession); if hr <> S_OK 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', #13#10, ['.', ' '], 42), mtError, [mbOK], 0); end; exit; end; OpenPST; finally if Assigned(DisplayName) then FreeMem(DisplayName); if Assigned(Password) then FreeMem(Password); if failed(hr) then ShowMessage('I cannot open "Personal Information Store"'); if Assigned(FProfileName) then begin HrCleanupPSTGlobals(FProfileName); MapiFreeBuffer(FProfileName); FProfileName := nil; end; end; end; function TPSTForm.IsSystemFolder(FolderEntryID: PSBinary): boolean; begin Result := False; if Assigned(FRootEID) then Result := IsSameBinary(FolderEntryID^, FRootEID^); if Result then exit; if Assigned(FInBoxEID) then Result := IsSameBinary(FolderEntryID^, FInBoxEID^); if Result then exit; if Assigned(FOutBoxEID) then Result := IsSameBinary(FolderEntryID^, FOutBoxEID^); if Result then exit; if Assigned(FTrashBoxEID) then Result := IsSameBinary(FolderEntryID^, FTrashBoxEID^); if Result then exit; if Assigned(FSentBoxEID) then Result := IsSameBinary(FolderEntryID^, FSentBoxEID^); end; procedure TPSTForm.FormCreate(Sender: TObject); var MAPIINIT: TMAPIINIT; const MAPI_TEMPORARY_PROFILES = $00000004; begin ClearBoxes; FTable := nil; FSelected := nil; FCanClose := True; FMDB := nil; FMAPISession := nil; ZeroMemory(@MAPIINIT, SizeOf(TMAPIINIT)); MAPIINIT.ulVersion := MAPI_INIT_VERSION; MAPIINIT.ulFlags := MAPI_TEMPORARY_PROFILES; hr := MAPIInitialize(@MAPIINIT); if failed(hr) then ShowMessage(GetMAPIError(nil, hr)); FFolderMessagesList := TList.Create; {$IF DEFINED (WIN64)} self.Caption := self.Caption + ' - WIN64'; {$ELSE} self.Caption := self.Caption + ' - WIN32'; {$IFEND} end; procedure TPSTForm.FormClose(Sender: TObject; var Action: TCloseAction); var flag: ULONG; begin ClearMessagesList; ClearBoxes; ClearContentTable; FTable := nil; ClearTTree(Mailbox); flag := LOGOFF_NO_WAIT; if Assigned(FMDB) then FMDB.StoreLogoff(flag); FMDB := nil; if Assigned(FMAPISession) then FMAPISession.Logoff(Application.Handle, MAPI_LOGOFF_UI, 0); FMAPISession := nil; if Assigned(FProfileName) then begin HrCleanupPSTGlobals(FProfileName); MapiFreeBuffer(FProfileName); FProfileName := nil; end; FreeAndNil(FFolderMessagesList); MAPIUnInitialize; end; procedure TPSTForm.OpenPST; var StoreEID: TSBinary; FLAGS: ULONG; begin ZeroMemory(@StoreEID, SizeOf(TSBinary)); try hr := HrMAPIFindDefaultMsgStore(FMAPISession, StoreEID.cb, PENTRYID(StoreEID.lpb)); if failed(hr) then exit; hr := FMAPISession.OpenMsgStore(Application.Handle, StoreEID.cb, PENTRYID(StoreEID.lpb), nil, MAPI_BEST_ACCESS or MDB_WRITE, FMDB); if failed(hr) then exit; hr := GetSystemMAPIFolders(FMDB, FCreate, FInBoxEID, FOutBoxEID, FTrashBoxEID, FSentBoxEID, FRootEID); if failed(hr) then exit; GetFolderRoot(Mailbox); finally if Assigned(StoreEID.lpb) then MapiFreeBuffer(StoreEID.lpb); if failed(hr) and Assigned(FMDB) then begin FLAGS := LOGOFF_ABORT; FMDB.StoreLogoff(FLAGS); FMDB := nil; end; btImport.Enabled := Succeeded(hr); end; end; procedure TPSTForm.GetFolderRoot(twMailbox: TTreeView); var RootFolder: IMAPIFolder; Node: TTreeNode; ObjType: ULONG; FIMPRoot: PSBinary; begin FCanClose := False; RootFolder := nil; ClearTTree(twMailbox); twMailbox.Items.BeginUpdate; try hr := FMDB.OpenEntry(FRootEID.cb, PENTRYID(FRootEID.lpb), @IID_IMAPIFolder, MAPI_DEFERRED_ERRORS, ObjType, IUnknown(RootFolder)); if failed(hr) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; if not MakePSBinary(FRootEID^, FIMPRoot) then exit; Node := twMailbox.Items.AddObjectFirst(nil, 'Mailbox', FIMPRoot); Node.ImageIndex := 0; EnumFolders(RootFolder, Node, twMailbox); finally RootFolder := nil; twMailbox.Items.EndUpdate; FCanClose := True; end; end; procedure TPSTForm.EnumFolders(ParentFolder: IMAPIFolder; Node: TTreeNode; twMailbox: TTreeView); var Subfolder: IMAPIFolder; SubNode: TTreeNode; HierarchyTable: IMAPITable; ObjType, RowCount: ULONG; iCount: ULONG; RowSet: PSRowSet; PropTagArray: PSPropTagArray; FolderAsProp: IMAPIProp; FolderPropValues: PSPropValue; FolderEntryID: PSBinary; IsSystemBox: Bool; type ef = (ePR_DISPLAY_NAME, ePR_ENTRYID, ePR_SUBFOLDERS, ePR_CONTAINER_CLASS); begin if (Assigned(ParentFolder) = False) or (Assigned(Node) = False) then exit; FCanClose := False; HierarchyTable := nil; PropTagArray := nil; RowSet := nil; FolderAsProp := nil; FolderPropValues := nil; IsSystemBox := False; 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; 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; 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 SizedSPropTagArray([PR_DISPLAY_NAME, PR_ENTRYID, PR_SUBFOLDERS, PR_CONTAINER_CLASS], PropTagArray); for iCount := 0 to RowSet.cRows - 1 do begin IsSystemBox := False; hr := ParentFolder.OpenEntry(PSPropValueArray(RowSet.aRow[iCount].lpProps)[0].Value.bin.cb, PENTRYID(PSPropValueArray(RowSet.aRow[iCount].lpProps)[0].Value.bin.lpb), nil, MAPI_BEST_ACCESS, 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); if not IsSystemBox then begin hr := FMDB.CompareEntryIDs(FolderEntryID.cb, PENTRYID(FolderEntryID.lpb), FInBoxEID.cb, PENTRYID(FInBoxEID.lpb), 0, ULONG(IsSystemBox)); if failed(hr) and (hr <> MAPI_E_UNKNOWN_ENTRYID) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; if IsSystemBox then SubNode.ImageIndex := 2; end; if not IsSystemBox then begin hr := FMDB.CompareEntryIDs(FolderEntryID.cb, PENTRYID(FolderEntryID.lpb), FTrashBoxEID.cb, PENTRYID(FTrashBoxEID.lpb), 0, ULONG(IsSystemBox)); if failed(hr) and (hr <> MAPI_E_UNKNOWN_ENTRYID) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; if IsSystemBox then SubNode.ImageIndex := 12; end; if not IsSystemBox then begin hr := FMDB.CompareEntryIDs(FolderEntryID.cb, PENTRYID(FolderEntryID.lpb), FOutBoxEID.cb, PENTRYID(FOutBoxEID.lpb), 0, ULONG(IsSystemBox)); if failed(hr) and (hr <> MAPI_E_UNKNOWN_ENTRYID) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; if IsSystemBox then SubNode.ImageIndex := 13; end; if not IsSystemBox then begin hr := FMDB.CompareEntryIDs(FolderEntryID.cb, PENTRYID(FolderEntryID.lpb), FSentBoxEID.cb, PENTRYID(FSentBoxEID.lpb), 0, ULONG(IsSystemBox)); if failed(hr) and (hr <> MAPI_E_UNKNOWN_ENTRYID) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; if IsSystemBox then SubNode.ImageIndex := 14; end; if not IsSystemBox then 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; 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, ObjType, IUnknown(Subfolder)); if failed(hr) then begin MessageDlg(GetMAPIError(ParentFolder, hr), mtError, [mbOK], 0); exit; end; EnumFolders(Subfolder, SubNode, twMailbox); 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; FCanClose := True; end; end; procedure TPSTForm.CreateSubFolder1Click(Sender: TObject); var Subfolder, ParentFolder: IMAPIFolder; ulObjType: ULONG; PropValue: PSPropValue; NewFolderEID: PSBinary; FolderType: PChar; begin Subfolder := nil; ParentFolder := nil; PropValue := nil; FormNewFolder := nil; FolderType := nil; if not Assigned(Mailbox.selected) then exit; try hr := FMDB.OpenEntry(PSBinary(Mailbox.selected.Data).cb, PENTRYID(PSBinary(Mailbox.selected.Data).lpb), @IID_IMAPIFolder, MAPI_DEFERRED_ERRORS or MAPI_MODIFY or MAPI_BEST_ACCESS, ulObjType, IUnknown(ParentFolder)); if failed(hr) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; FormNewFolder := TFormNewFolder.Create(self); if FormNewFolder.ShowModal = mrOk then begin hr := ParentFolder.CreateFolder(FOLDER_GENERIC, PChar(Trim(FormNewFolder.ebFolderName.Text)), PChar(Trim(FormNewFolder.ebFolderComment.Text)), nil, fMAPIUnicode, Subfolder); if failed(hr) then begin MessageDlg(GetMAPIError(ParentFolder, hr), mtError, [mbOK], 0); exit; end; hr := Subfolder.SaveChanges(0); if failed(hr) then begin MessageDlg(GetMAPIError(Subfolder, hr), mtError, [mbOK], 0); exit; end; GetMem(FolderType, Length(Trim((FormNewFolder.cbFolderType.Text))) * SizeOf(Char) + 4 * SizeOf(Char) + 1); // +4 for 'IPF.' StrPCopy(FolderType, 'IPF.' + Trim((FormNewFolder.cbFolderType.Text))); hr := HrMAPISetPropString(Subfolder, PR_CONTAINER_CLASS, FolderType); if failed(hr) then exit; hr := Subfolder.SaveChanges(0); if failed(hr) then begin MessageDlg(GetMAPIError(Subfolder, hr), mtError, [mbOK], 0); exit; end; end else exit; if failed(hr) then exit; hr := HrGetOneProp(Subfolder, PR_ENTRYID, PropValue); if failed(hr) then exit; MakePSBinary(PropValue.Value.bin, NewFolderEID); ulObjType := Mailbox.Items.AddChildObject(Mailbox.selected, Trim(FormNewFolder.ebFolderName.Text), NewFolderEID).AbsoluteIndex; finally if Assigned(PropValue) then MapiFreeBuffer(PropValue); if Assigned(FormNewFolder) then FreeAndNil(FormNewFolder); if Assigned(ParentFolder) then ParentFolder := nil; if Assigned(Subfolder) then Subfolder := nil; if Assigned(FolderType) then FreeMem(FolderType); GetFolderRoot(Mailbox); Mailbox.Items.Item[ulObjType].selected := True; MailboxClick(nil); end; end; procedure TPSTForm.DeleteFolder1Click(Sender: TObject); var FolderEntryID: PSPropValue; ParentEntryID: PSPropValue; Folder: IMAPIFolder; ulObjType: ULONG; bSystem: boolean; begin Folder := nil; FolderEntryID := nil; ParentEntryID := nil; bSystem := False; if (MessageDlg('Warning!!!' + #13#10 + 'All messages will be erased with no option for recovery!' + #13#10 + 'Continue? ', mtConfirmation, [mbOK, mbAbort], 0) <> mrOk) then exit; if not Assigned(Mailbox.selected) then exit; try hr := FMDB.OpenEntry(PSBinary(Mailbox.selected.Data).cb, PENTRYID(PSBinary(Mailbox.selected.Data).lpb), @IID_IMAPIFolder, MAPI_MODIFY or MAPI_BEST_ACCESS, ulObjType, IUnknown(Folder)); if failed(hr) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; hr := HrGetOneProp(Folder, PR_ENTRYID, FolderEntryID); if failed(hr) then exit; if IsSystemFolder(@FolderEntryID.Value.bin) then begin MessageDlg('Warning!!! ' + #13#10 + 'You cannot erase a system folder!', mtError, [mbOK], 0); bSystem := True; exit; end; hr := HrGetOneProp(Folder, PR_PARENT_ENTRYID, ParentEntryID); if failed(hr) then exit; Folder := nil; hr := FMDB.OpenEntry(ParentEntryID.Value.bin.cb, PENTRYID(ParentEntryID.Value.bin.lpb), @IID_IMAPIFolder, MAPI_MODIFY or MAPI_BEST_ACCESS, ulObjType, IUnknown(Folder)); if failed(hr) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; hr := Folder.DeleteFolder(FolderEntryID.Value.bin.cb, PENTRYID(FolderEntryID.Value.bin.lpb), Application.Handle, nil, DEL_MESSAGES or FOLDER_DIALOG); if failed(hr) then begin MessageDlg(GetMAPIError(Folder, hr), mtError, [mbOK], 0); exit end else begin FreeMem(Mailbox.selected.Data); ulObjType := Mailbox.selected.Parent.AbsoluteIndex; Mailbox.selected.Delete; end; finally if Assigned(Folder) then Folder := nil; if Assigned(FolderEntryID) then MapiFreeBuffer(FolderEntryID); if Assigned(ParentEntryID) then MapiFreeBuffer(ParentEntryID); if Succeeded(hr) and not bSystem then begin GetFolderRoot(Mailbox); Mailbox.Items.Item[ulObjType].selected := True; MailboxClick(nil); end; end; end; procedure TPSTForm.ShowMapiProp(cValues: ULONG; PropValues: PSPropValue); var iCount: ULONG; ListItem: TListItem; strTemp: string; FTempVariant: olevariant; _iCount: Integer; begin if (cValues <= 0) or not Assigned(PropValues) then exit; ListViewFolder.Items.BeginUpdate; try ListViewFolder.Items.Clear; for iCount := 0 to cValues - 1 do begin ListItem := ListViewFolder.Items.Add; ListItem.Caption := SzGetPropTag(PSPropValueArray(PropValues)[iCount].ulPropTag); case PROP_TYPE(PSPropValueArray(PropValues)[iCount].ulPropTag) of PT_SHORT, PT_LONG, PT_FLOAT, PT_DOUBLE, PT_BOOLEAN, PT_APPTIME, PT_SYSTIME, PT_STRING8, PT_UNICODE: begin ListItem.SubItems.Add(SzGetPropType(PSPropValueArray(PropValues)[iCount].ulPropTag)); ListItem.SubItems.Add(ConvertMAPIPropValueToVariant(@PSPropValueArray(PropValues)[iCount])); end; PT_BINARY: begin ListItem.SubItems.Add(SzGetPropType(PSPropValueArray(PropValues)[iCount].ulPropTag)); strTemp := ''; FTempVariant := ConvertMAPIPropValueToVariant(@PSPropValueArray(PropValues)[iCount]); for _iCount := 0 to VarArrayHighBound(FTempVariant, 1) do strTemp := strTemp + ' ' + IntToHex(byte(FTempVariant[_iCount]), 2); strTemp := 'cb:' + IntToStr(VarArrayHighBound(FTempVariant, 1) + 1) + ', lpb:' + Trim(strTemp); ListItem.SubItems.Add(Trim(strTemp)); end; PT_MV_STRING8, PT_MV_UNICODE: begin FTempVariant := ConvertMAPIPropValueToVariant(@PSPropValueArray(PropValues)[iCount]); for _iCount := 0 to VarArrayHighBound(FTempVariant, 1) do begin if _iCount > 0 then begin ListItem := ListViewFolder.Items.Add; ListItem.Caption := SzGetPropTag(PSPropValueArray(PropValues)[iCount].ulPropTag); end; ListItem.SubItems.Add(SzGetPropType(PSPropValueArray(PropValues)[iCount].ulPropTag)); ListItem.SubItems.Add(FTempVariant[_iCount]); end; end else begin ListItem.SubItems.Add(SzGetPropType(PSPropValueArray(PropValues)[iCount].ulPropTag) + ' - Not implemented'); ListItem.SubItems.Add('A MAPI Value'); end end; end; finally ListViewFolder.Items.EndUpdate; end; end; procedure TPSTForm.ClearMessagesList; begin lvMailbox.Items.BeginUpdate; ClearFIMList(FFolderMessagesList); lvMailbox.Items.Count := 0; lvMailbox.Items.EndUpdate; lvMailbox.Repaint; Application.ProcessMessages; end; procedure TPSTForm.ClearContentTable; begin FTable := nil; end; procedure TPSTForm.EnumFolder(Folder: IMAPIFolder); begin ClearMessagesList; ClearContentTable; hr := Folder.GetContentsTable(0, FTable); if failed(hr) then begin MessageDlg(GetMAPIError(Folder, hr), mtError, [mbOK], 0); exit; end; LoadMessages(FTable); end; function TPSTForm.AddItemToListBox(Lock: Bool; iRow: Integer; RowToAdd: PSRow): int64; var UserMessageProperties: PUserMessage; iCount: Integer; MessageSizeCount: ULONG; type pr = (ePR_HASATTACH, ePR_MESSAGE_FLAGS, ePR_SUBJECT, ePR_MESSAGE_SIZE, ePR_MESSAGE_DELIVERY_TIME, ePR_ENTRYID, ePR_INSTANCE_KEY); begin if Lock then lvMailbox.Items.BeginUpdate; Result := 0; GetMem(UserMessageProperties, SizeOf(TUserMessage)); ZeroMemory(UserMessageProperties, SizeOf(TUserMessage)); if (PSPropValueArray(RowToAdd.lpProps)[Ord(ePR_HASATTACH)].ulPropTag = PR_HASATTACH) then UserMessageProperties.PR_HASATTACH := boolean(PSPropValueArray(RowToAdd.lpProps)[Ord(ePR_HASATTACH)].Value.B); UserMessageProperties.PR_SUBJECT := nil; if (PSPropValueArray(RowToAdd.lpProps)[Ord(ePR_SUBJECT)].ulPropTag = PR_SUBJECT) then if Assigned(PSPropValueArray(RowToAdd.lpProps)[Ord(ePR_SUBJECT)].Value.lpsz) then begin GetMem(UserMessageProperties.PR_SUBJECT, StrLen(PSPropValueArray(RowToAdd.lpProps)[Ord(ePR_SUBJECT)].Value.lpsz) * SizeOf(Char) + 1); StrCopy(UserMessageProperties.PR_SUBJECT, PSPropValueArray(RowToAdd.lpProps)[Ord(ePR_SUBJECT)].Value.lpsz); end; if (PSPropValueArray(RowToAdd.lpProps)[Ord(ePR_MESSAGE_SIZE)].ulPropTag = PR_MESSAGE_SIZE) then begin UserMessageProperties.PR_MESSAGE_SIZE := PSPropValueArray(RowToAdd.lpProps)[Ord(ePR_MESSAGE_SIZE)].Value.ul; Result := UserMessageProperties.PR_MESSAGE_SIZE; end; if (PSPropValueArray(RowToAdd.lpProps)[Ord(ePR_MESSAGE_DELIVERY_TIME)].ulPropTag = PR_MESSAGE_DELIVERY_TIME) then UserMessageProperties.PR_CLIENT_SUBMIT_TIME := VarToDateTime(ConvertMAPIPropValueToVariant(@PSPropValueArray(RowToAdd.lpProps)[Ord(ePR_MESSAGE_DELIVERY_TIME)])); if (PSPropValueArray(RowToAdd.lpProps)[Ord(ePR_ENTRYID)].ulPropTag = PR_ENTRYID) then MakePSBinary(PSPropValueArray(RowToAdd.lpProps)[Ord(ePR_ENTRYID)].Value.bin, UserMessageProperties.PR_ENTRYID); if (PSPropValueArray(RowToAdd.lpProps)[Ord(ePR_MESSAGE_FLAGS)].ulPropTag = PR_MESSAGE_FLAGS) then UserMessageProperties.PR_MESSAGE_FLAGS := PSPropValueArray(RowToAdd.lpProps)[Ord(ePR_MESSAGE_FLAGS)].Value.L; if (PSPropValueArray(RowToAdd.lpProps)[Ord(ePR_INSTANCE_KEY)].ulPropTag = PR_INSTANCE_KEY) then MakeMAPIUID(PSPropValueArray(RowToAdd.lpProps)[Ord(ePR_INSTANCE_KEY)].Value.bin, UserMessageProperties.PR_INSTANCE_KEY); FFolderMessagesList.Insert(iRow, UserMessageProperties); if Lock then begin MessageSizeCount := 0; for iCount := 0 to FFolderMessagesList.Count - 1 do MessageSizeCount := MessageSizeCount + ShellItem(iCount).PR_MESSAGE_SIZE; UpdatePanels(MessageSizeCount); end; end; procedure TPSTForm.UpdatePanels(MessageSizeCount: ULONG); begin StatusBar1.Panels.Clear; StatusBar1.Panels.Add; StatusBar1.Panels.Add; StatusBar1.Panels[0].Style := psText; StatusBar1.Panels[0].Text := IntToStr(FFolderMessagesList.Count) + ' 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; FFolderMessagesList.Sort(CustomSortProc); lvMailbox.Items.Count := FFolderMessagesList.Count; lvMailbox.Items.EndUpdate; end; procedure TPSTForm.LoadMessages(Table: IMAPITable); var ContentTablePropTagArray: PSPropTagArray; ContentTableRowCount: ULONG; ProgresBar: TProgressBar; RowSet: PSRowSet; Count: ULONG; MessageSizeCount: ULONG; begin ContentTablePropTagArray := nil; RowSet := nil; ProgresBar := nil; MessageSizeCount := 0; FCanClose := False; try SizedSPropTagArray([PR_HASATTACH, PR_MESSAGE_FLAGS, PR_SUBJECT, PR_MESSAGE_SIZE, PR_MESSAGE_DELIVERY_TIME, PR_ENTRYID, PR_INSTANCE_KEY], ContentTablePropTagArray); hr := Table.SetColumns(ContentTablePropTagArray, 0); if failed(hr) then begin MessageDlg(GetMAPIError(Table, hr), mtError, [mbOK], 0); exit; end; MapiFreeBuffer(ContentTablePropTagArray); ContentTablePropTagArray := nil; hr := Table.SeekRow(BOOKMARK_BEGINNING, 0, Integer(nil^)); 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 Count := 0 to RowSet.cRows - 1 do begin if ((Count mod 100) = 0) then Application.ProcessMessages; ProgresBar.StepIt; MessageSizeCount := MessageSizeCount + AddItemToListBox(False, Count, @RowSet.aRow[Count]); end; if Assigned(RowSet) then FreePRows(RowSet); RowSet := nil; end; end; end; finally if Assigned(ContentTablePropTagArray) then MapiFreeBuffer(ContentTablePropTagArray); if Assigned(RowSet) then FreePRows(RowSet); UpdatePanels(MessageSizeCount); if Assigned(ProgresBar) then ProgresBar.Free; FCanClose := True; end; end; procedure TPSTForm.MailboxClick(Sender: TObject); var Folder: IMAPIFolder; ObjType: ULONG; cValues: ULONG; PropValues: PSPropValue; begin if not Assigned(Mailbox.selected) or (Mailbox.selected = FSelected) then exit; FSelected := Mailbox.selected; self.Enabled := False; FCanClose := False; PropValues := nil; Folder := nil; try hr := FMDB.OpenEntry(PSBinary(Mailbox.selected.Data).cb, PENTRYID(PSBinary(Mailbox.selected.Data).lpb), @IID_IMAPIFolder, MAPI_DEFERRED_ERRORS or MAPI_MODIFY or MAPI_BEST_ACCESS, ObjType, IUnknown(Folder)); if failed(hr) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; hr := Folder.GetProps(nil, 0, cValues, PropValues); if failed(hr) or (cValues <= 0) or not Assigned(PropValues) then exit; ShowMapiProp(cValues, PropValues); EnumFolder(Folder); finally if Assigned(PropValues) then MapiFreeBuffer(PropValues); Folder := nil; self.Enabled := True; FCanClose := True; end; end; procedure TPSTForm.EmptyFolder1Click(Sender: TObject); var Folder: IMAPIFolder; ulObjType: ULONG; MAPIProgress: IMAPIProgress; FolderEntryID: PSPropValue; bSystem: boolean; begin bSystem := False; if (MessageDlg('Warning!!! ' + #13#10 + 'All messages and subfolders will be erased with no option for recovery!' + #13#10 + 'Continue?', mtConfirmation, [mbOK, mbAbort], 0) <> mrOk) then exit; if not Assigned(Mailbox.selected) then exit; MAPIProgress := TMAPIProgress.Create(Application); try hr := FMDB.OpenEntry(PSBinary(Mailbox.selected.Data).cb, PENTRYID(PSBinary(Mailbox.selected.Data).lpb), @IID_IMAPIFolder, MAPI_DEFERRED_ERRORS or MAPI_MODIFY or MAPI_BEST_ACCESS, ulObjType, IUnknown(Folder)); if failed(hr) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; hr := HrGetOneProp(Folder, PR_ENTRYID, FolderEntryID); if failed(hr) then exit; if IsSameBinary(FolderEntryID.Value.bin, FRootEID^) then begin MessageDlg('Warning!!! ' + #13#10 + 'You cannot erase a system folder!', mtError, [mbOK], 0); bSystem := True; exit; end; hr := Folder.EmptyFolder(Application.Handle, MAPIProgress, FOLDER_DIALOG); if failed(hr) then begin MessageDlg(GetMAPIError(Folder, hr), mtError, [mbOK], 0); exit; end; finally Folder := nil; MAPIProgress := nil; ulObjType := Mailbox.selected.AbsoluteIndex; if Assigned(FolderEntryID) then MapiFreeBuffer(FolderEntryID); if not bSystem then begin GetFolderRoot(Mailbox); Mailbox.Items.Item[ulObjType].selected := True; MailboxClick(nil); end; end; end; procedure TPSTForm.CopyFolder1Click(Sender: TObject); var Folder, DestFolder: IMAPIFolder; ulObjType: ULONG; DestinationEID: PSBinary; MAPIProgress: IMAPIProgress; begin if not Assigned(Mailbox.selected) then exit; if not Assigned(Mailbox.selected.Parent) then exit; DestinationEID := nil; DestFolder := nil; frmCopyMove := TfrmCopyMove.Create(self); frmCopyMove.Caption := ' Copy folder'; frmCopyMove.lbAction.Caption := 'Copy the selected folder to the folder:'; try GetFolderRoot(frmCopyMove.MailboxDest); frmCopyMove.MailboxDest.Items.Item[Mailbox.selected.AbsoluteIndex].selected := True; if frmCopyMove.ShowModal = mrOk then MakePSBinary(frmCopyMove.DestFolderID^, DestinationEID) else exit; finally ClearTTree(frmCopyMove.MailboxDest); FreeAndNil(frmCopyMove); end; if not Assigned(DestinationEID) or IsSameBinary(DestinationEID^, PSBinary(Mailbox.selected.Data)^) then begin MessageDlg('Warning!!! ' + #13#10 + 'Source and target are the same!', mtError, [mbOK], 0); FreePSBinary(DestinationEID); exit; end; MAPIProgress := TMAPIProgress.Create(Application); try hr := FMDB.OpenEntry(PSBinary(Mailbox.selected.Parent.Data).cb, PENTRYID(PSBinary(Mailbox.selected.Parent.Data).lpb), @IID_IMAPIFolder, MAPI_DEFERRED_ERRORS or MAPI_MODIFY or MAPI_BEST_ACCESS, ulObjType, IUnknown(Folder)); if failed(hr) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; hr := FMDB.OpenEntry(DestinationEID.cb, PENTRYID(DestinationEID.lpb), @IID_IMAPIFolder, MAPI_DEFERRED_ERRORS or MAPI_MODIFY or MAPI_BEST_ACCESS, ulObjType, IUnknown(DestFolder)); if failed(hr) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; hr := Folder.CopyFolder(PSBinary(Mailbox.selected.Data).cb, PENTRYID(PSBinary(Mailbox.selected.Data).lpb), nil, Pointer(DestFolder), nil, Application.Handle, MAPIProgress, COPY_SUBFOLDERS or MAPI_DECLINE_OK or FOLDER_DIALOG); if failed(hr) then begin MessageDlg(GetMAPIError(Folder, hr), mtError, [mbOK], 0); exit; end; finally Folder := nil; MAPIProgress := nil; DestFolder := nil; ulObjType := Mailbox.selected.AbsoluteIndex; FreePSBinary(DestinationEID); GetFolderRoot(Mailbox); Mailbox.Items.Item[ulObjType].selected := True; MailboxClick(nil); end; end; procedure TPSTForm.MoveFolder1Click(Sender: TObject); var Folder, DestFolder: IMAPIFolder; ObjType: ULONG; DestinationEID: PSBinary; MAPIProgress: IMAPIProgress; begin if not Assigned(Mailbox.selected) or not Assigned(Mailbox.selected.Parent) then exit; DestinationEID := nil; DestFolder := nil; frmCopyMove := TfrmCopyMove.Create(self); frmCopyMove.Caption := ' Move folder'; frmCopyMove.lbAction.Caption := 'Move the selected folder to the folder:'; try GetFolderRoot(frmCopyMove.MailboxDest); frmCopyMove.MailboxDest.Items.Item[Mailbox.selected.AbsoluteIndex].selected := True; if not(frmCopyMove.ShowModal = mrOk) or not MakePSBinary(frmCopyMove.DestFolderID^, DestinationEID) then exit; finally ClearTTree(frmCopyMove.MailboxDest); FreeAndNil(frmCopyMove); end; if not Assigned(DestinationEID) or IsSameBinary(DestinationEID^, PSBinary(Mailbox.selected.Data)^) then begin MessageDlg('Warning!!! ' + #13#10 + 'Source and target are the same!', mtError, [mbOK], 0); FreePSBinary(DestinationEID); exit; end; MAPIProgress := TMAPIProgress.Create(Application); try hr := FMDB.OpenEntry(PSBinary(Mailbox.selected.Parent.Data).cb, PENTRYID(PSBinary(Mailbox.selected.Parent.Data).lpb), @IID_IMAPIFolder, MAPI_DEFERRED_ERRORS or MAPI_MODIFY or MAPI_BEST_ACCESS, ObjType, IUnknown(Folder)); if failed(hr) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; hr := FMDB.OpenEntry(DestinationEID.cb, PENTRYID(DestinationEID.lpb), @IID_IMAPIFolder, MAPI_DEFERRED_ERRORS or MAPI_MODIFY or MAPI_BEST_ACCESS, ObjType, IUnknown(DestFolder)); if failed(hr) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; hr := Folder.CopyFolder(PSBinary(Mailbox.selected.Data).cb, PENTRYID(PSBinary(Mailbox.selected.Data).lpb), nil, Pointer(DestFolder), nil, Application.Handle, MAPIProgress, COPY_SUBFOLDERS or MAPI_DECLINE_OK or FOLDER_MOVE or FOLDER_DIALOG); if failed(hr) then begin MessageDlg(GetMAPIError(Folder, hr), mtError, [mbOK], 0); exit; end; finally Folder := nil; MAPIProgress := nil; DestFolder := nil; ObjType := Mailbox.selected.AbsoluteIndex; FreePSBinary(DestinationEID); GetFolderRoot(Mailbox); Mailbox.Items.Item[ObjType].selected := True; MailboxClick(nil); end; end; procedure TPSTForm.lvMailboxData(Sender: TObject; Item: TListItem); begin if FFolderMessagesList.Count = 0 then exit; if (Item.Index > FFolderMessagesList.Count) then exit; try 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'); if YearOf(PR_CLIENT_SUBMIT_TIME) > 1900 then Item.SubItems.Add(DateTimeToStr(PR_CLIENT_SUBMIT_TIME)) else Item.SubItems.Add('none'); end; except ShowMessage('ERROR'); end; end; procedure TPSTForm.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 TPSTForm.lvMailboxMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin lvPopMenu.AutoPopup := Assigned(lvMailbox.selected); end; procedure TPSTForm.CopyMessagesto1Click(Sender: TObject); begin CopyOrMoveMessages; end; procedure TPSTForm.MoveMessagesto1Click(Sender: TObject); begin CopyOrMoveMessages(True); end; procedure TPSTForm.CopyOrMoveMessages(Move: boolean = False); var MsgList: PENTRYLIST; Count: Integer; Item: TListItem; MAPIProgress: IMAPIProgress; DestinationEID: PSBinary; Folder, DestFolder: IMAPIFolder; ObjType: ULONG; FLAGS: ULONG; begin if not Assigned(Mailbox.selected) or not Assigned(Mailbox.selected.Parent) or (lvMailbox.selected = nil) then exit; MsgList := nil; FLAGS := 0; Count := lvMailbox.SelCount; FCanClose := False; try hr := MAPIAllocateBuffer(SizeOf(TENTRYLIST), Pointer(MsgList)); if failed(hr) then begin ShowMessage('ERROR'); exit; end; hr := MAPIAllocateMore(Count * SizeOf(TSBinary), MsgList, Pointer(MsgList.lpbin)); if failed(hr) then begin ShowMessage('ERROR'); exit; end; MsgList.cValues := Count; Item := lvMailbox.selected; Count := 0; while Item <> nil do begin CopyMemory(@PSBinArray(MsgList.lpbin)[Count].cb, @PSBinary(Item.Data).cb, SizeOf(ULONG)); hr := MAPIAllocateMore(PSBinArray(MsgList.lpbin)[Count].cb, MsgList, Pointer(PSBinArray(MsgList.lpbin)[Count].lpb)); if failed(hr) then begin ShowMessage('ERROR'); exit; end; CopyMemory(PSBinArray(MsgList.lpbin)[Count].lpb, PSBinary(Item.Data).lpb, PSBinArray(MsgList.lpbin)[Count].cb); Item := lvMailbox.GetNextItem(Item, sdAll, [isSelected]); Inc(Count); end; DestinationEID := nil; DestFolder := nil; frmCopyMove := TfrmCopyMove.Create(self); if Move then begin frmCopyMove.Caption := ' Move Messages'; frmCopyMove.lbAction.Caption := 'Move the selected Messages to the folder:'; end else begin frmCopyMove.Caption := ' Copy Messages'; frmCopyMove.lbAction.Caption := 'Copy the selected Messages to the folder:'; end; try GetFolderRoot(frmCopyMove.MailboxDest); frmCopyMove.MailboxDest.Items.Item[Mailbox.selected.AbsoluteIndex].selected := True; if not(frmCopyMove.ShowModal = mrOk) or not MakePSBinary(frmCopyMove.DestFolderID^, DestinationEID) then exit; finally ClearTTree(frmCopyMove.MailboxDest); FreeAndNil(frmCopyMove); end; if not Assigned(DestinationEID) or IsSameBinary(DestinationEID^, PSBinary(Mailbox.selected.Data)^) then begin MessageDlg('Warning!!! ' + #13#10 + 'Source and target are the same!', mtError, [mbOK], 0); FreePSBinary(DestinationEID); exit; end; if IsSameBinary(DestinationEID^, FRootEID^) then begin MessageDlg('Warning!!!' + #13#10 + 'You may not copy/move to Root folder!', mtError, [mbOK], 0); FreePSBinary(DestinationEID); exit; end; try hr := FMDB.OpenEntry(PSBinary(Mailbox.selected.Data).cb, PENTRYID(PSBinary(Mailbox.selected.Data).lpb), @IID_IMAPIFolder, MAPI_DEFERRED_ERRORS or MAPI_MODIFY or MAPI_BEST_ACCESS, ObjType, IUnknown(Folder)); if failed(hr) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; hr := FMDB.OpenEntry(DestinationEID.cb, PENTRYID(DestinationEID.lpb), @IID_IMAPIFolder, MAPI_DEFERRED_ERRORS or MAPI_MODIFY or MAPI_BEST_ACCESS, ObjType, IUnknown(DestFolder)); if failed(hr) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; if Move then FLAGS := MESSAGE_MOVE; self.Enabled := False; MAPIProgress := TMAPIProgress.Create(Application); try hr := Folder.CopyMessages(MsgList, nil, Pointer(DestFolder), Application.Handle, MAPIProgress, MESSAGE_DIALOG or FLAGS); finally MAPIProgress := nil; self.Enabled := True; end; if failed(hr) then begin MessageDlg(GetMAPIError(Folder, hr), mtError, [mbOK], 0); exit; end; finally Folder := nil; MAPIProgress := nil; DestFolder := nil; ObjType := Mailbox.selected.AbsoluteIndex; FreePSBinary(DestinationEID); GetFolderRoot(Mailbox); Mailbox.Items.Item[ObjType].selected := True; MailboxClick(nil); end; finally if Assigned(MsgList) then MapiFreeBuffer(MsgList); FCanClose := True; end; end; procedure TPSTForm.DeleteMessages; var MsgList: PENTRYLIST; Count: Integer; Item: TListItem; MAPIProgress: IMAPIProgress; Folder, DestFolder: IMAPIFolder; ObjType: ULONG; begin if not Assigned(Mailbox.selected) or (lvMailbox.selected = nil) then exit; MsgList := nil; Count := lvMailbox.SelCount; FCanClose := False; try hr := MAPIAllocateBuffer(SizeOf(TENTRYLIST), Pointer(MsgList)); if failed(hr) then begin ShowMessage('ERROR'); exit; end; hr := MAPIAllocateMore(Count * SizeOf(TSBinary), MsgList, Pointer(MsgList.lpbin)); if failed(hr) then begin ShowMessage('ERROR'); exit; end; MsgList.cValues := Count; Item := lvMailbox.selected; Count := 0; while Item <> nil do begin CopyMemory(@PSBinArray(MsgList.lpbin)[Count].cb, @PSBinary(Item.Data).cb, SizeOf(ULONG)); hr := MAPIAllocateMore(PSBinArray(MsgList.lpbin)[Count].cb, MsgList, Pointer(PSBinArray(MsgList.lpbin)[Count].lpb)); if failed(hr) then begin ShowMessage('ERROR'); exit; end; CopyMemory(PSBinArray(MsgList.lpbin)[Count].lpb, PSBinary(Item.Data).lpb, PSBinArray(MsgList.lpbin)[Count].cb); Item := lvMailbox.GetNextItem(Item, sdAll, [isSelected]); Inc(Count); end; try hr := FMDB.OpenEntry(PSBinary(Mailbox.selected.Data).cb, PENTRYID(PSBinary(Mailbox.selected.Data).lpb), @IID_IMAPIFolder, MAPI_DEFERRED_ERRORS or MAPI_MODIFY or MAPI_BEST_ACCESS, ObjType, IUnknown(Folder)); if failed(hr) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; self.Enabled := False; MAPIProgress := TMAPIProgress.Create(Application); try hr := Folder.DeleteMessages(MsgList, Application.Handle, MAPIProgress, MESSAGE_DIALOG); finally MAPIProgress := nil; self.Enabled := True; end; if failed(hr) then begin MessageDlg(GetMAPIError(Folder, hr), mtError, [mbOK], 0); exit; end; finally Folder := nil; MAPIProgress := nil; DestFolder := nil; ObjType := Mailbox.selected.AbsoluteIndex; GetFolderRoot(Mailbox); Mailbox.Items.Item[ObjType].selected := True; MailboxClick(nil); end; finally if Assigned(MsgList) then MapiFreeBuffer(MsgList); FCanClose := True; end; end; procedure TPSTForm.FormCloseQuery(Sender: TObject; var CanClose: boolean); begin CanClose := FCanClose; end; procedure TPSTForm.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 FFolderMessagesList.Sort(CustomSortProc); lvMailbox.Repaint; end; procedure TPSTForm.lvMailboxClick(Sender: TObject); var Msg: IMAPIProp; cValues: ULONG; PropValues: PSPropValue; begin if lvMailbox.Items.Count > 0 then lvMailbox.ShowHint := True else lvMailbox.ShowHint := False; if Assigned(lvMailbox.selected) and (lvMailbox.SelCount = 1) then begin PropValues := nil; try hr := FMDB.OpenEntry(PSBinary(lvMailbox.selected.Data).cb, PENTRYID(PSBinary(lvMailbox.selected.Data).lpb), @IID_IMAPIProp, MAPI_DEFERRED_ERRORS or MAPI_MODIFY or MAPI_BEST_ACCESS, cValues, IUnknown(Msg)); if failed(hr) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; hr := Msg.GetProps(nil, 0, cValues, PropValues); if failed(hr) or (cValues <= 0) or not Assigned(PropValues) then exit; ShowMapiProp(cValues, PropValues); finally if Assigned(PropValues) then MapiFreeBuffer(PropValues); Msg := nil; end; end; end; procedure TPSTForm.DeleteMessages1Click(Sender: TObject); begin if (MessageDlg('Warning!!!' + #13#10 + 'All messages will be erased with no option for recovery!' + #13#10 + 'Continue?', mtConfirmation, [mbOK, mbAbort], 0) <> mrOk) then exit; DeleteMessages; end; procedure TPSTForm.lvMailboxDblClick(Sender: TObject); begin if lvMailbox.Items.Count > 0 then lvMailbox.ShowHint := True else lvMailbox.ShowHint := False; if Assigned(lvMailbox.selected) and (lvMailbox.SelCount = 1) then begin with TfrmMessage.Create(self) do try OpenMessage(FMDB, lvMailbox.selected.Data); ShowModal; finally Free; end; end; end; procedure TPSTForm.SelectAll1Click(Sender: TObject); begin lvMailbox.SelectAll; end; procedure TPSTForm.btImportClick(Sender: TObject); var MessageFileName: PWideChar; StorageOpen: IStorage; MessageFileNameLength: Integer; pMalloc: IMalloc; pIMsg: IMessage; MAPIFolder: IMAPIFolder; ObjType: ULONG; begin if not OpenDialog2.Execute then exit; MessageFileNameLength := (Length(OpenDialog2.FileName) + 1) * SizeOf(WCHAR); GetMem(MessageFileName, MessageFileNameLength); ZeroMemory(MessageFileName, MessageFileNameLength); StringToWideChar(OpenDialog2.FileName, MessageFileName, MessageFileNameLength); pMalloc := nil; StorageOpen := nil; try hr := StgOpenStorage(MessageFileName, nil, STGM_TRANSACTED or STGM_SHARE_EXCLUSIVE or STGM_READWRITE, nil, 0, StorageOpen); olecheck(hr); Pointer(pMalloc) := MAPIGetDefaultMalloc; // Open an IMessage interface on an IStorage object hr := OpenIMsgOnIStg(nil, @ExtendedMAPI.MAPIAllocateBuffer, @ExtendedMAPI.MAPIAllocateMore, @ExtendedMAPI.MapiFreeBuffer, pMalloc, nil, StorageOpen, nil, 0, 0, pIMsg); olecheck(hr); hr := FMDB.OpenEntry(FInBoxEID.cb, PENTRYID(FInBoxEID.lpb), @IID_IMAPIFolder, MAPI_DEFERRED_ERRORS or MAPI_BEST_ACCESS or MAPI_MODIFY, ObjType, IUnknown(MAPIFolder)); if failed(hr) then begin MessageDlg(GetMAPIError(FMDB, hr), mtError, [mbOK], 0); exit; end; if Assigned(pIMsg) then begin frmMessage := TfrmMessage.Create(self); frmMessage.OpenMessageFrom(MAPIFolder, pIMsg); frmMessage.ShowModal; frmMessage.Free; end; finally if Assigned(pIMsg) then pIMsg := nil; if Assigned(MAPIFolder) then MAPIFolder := nil; if Assigned(MessageFileName) then FreeMem(MessageFileName); if Assigned(StorageOpen) then StorageOpen := nil; if Assigned(pMalloc) then pMalloc := nil; FindInboxNode; end; end; procedure TPSTForm.FindInboxNode; var iCount: Integer; begin For iCount := 0 to Mailbox.Items.Count - 1 do begin if IsSameBinary(PSBinary(Mailbox.Items.Item[iCount].Data)^, FInBoxEID^) then begin Mailbox.Items.Item[iCount].selected := True; MailboxClick(nil); Break; end; end; end; end.