{********************************************************************} { } { Developer Express Visual Component Library } { ExpressEditors } { } { Copyright (c) 1998-2009 Developer Express Inc. } { ALL RIGHTS RESERVED } { } { The entire contents of this file is protected by U.S. and } { International Copyright Laws. Unauthorized reproduction, } { reverse-engineering, and distribution of all or any portion of } { the code contained in this file is strictly prohibited and may } { result in severe civil and criminal penalties and will be } { prosecuted to the maximum extent possible under the law. } { } { RESTRICTIONS } { } { THIS SOURCE CODE AND ALL RESULTING INTERMEDIATE FILES } { (DCU, OBJ, DLL, ETC.) ARE CONFIDENTIAL AND PROPRIETARY TRADE } { SECRETS OF DEVELOPER EXPRESS INC. THE REGISTERED DEVELOPER IS } { LICENSED TO DISTRIBUTE THE EXPRESSEDITORS AND ALL } { ACCOMPANYING VCL CONTROLS AS PART OF AN EXECUTABLE PROGRAM ONLY. } { } { THE SOURCE CODE CONTAINED WITHIN THIS FILE AND ALL RELATED } { FILES OR ANY PORTION OF ITS CONTENTS SHALL AT NO TIME BE } { COPIED, TRANSFERRED, SOLD, DISTRIBUTED, OR OTHERWISE MADE } { AVAILABLE TO OTHER INDIVIDUALS WITHOUT EXPRESS WRITTEN CONSENT } { AND PERMISSION FROM DEVELOPER EXPRESS INC. } { } { CONSULT THE END USER LICENSE AGREEMENT FOR INFORMATION ON } { ADDITIONAL RESTRICTIONS. } { } {********************************************************************} unit cxShellCommon; {$I cxVer.inc} interface uses {$IFNDEF DELPHI6} Mask, {$ELSE} MaskUtils, {$ENDIF} Windows, ActiveX, Classes, ComObj, Controls, Dialogs, Forms, Math, Messages, ShellApi, ShlObj, SyncObjs, SysUtils; resourcestring SShellDefaultNameStr = 'Name'; SShellDefaultSizeStr = 'Size'; SShellDefaultTypeStr = 'Type'; SShellDefaultModifiedStr = 'Modified'; const cxShellObjectInternalAbsoluteVirtualPathPrefix = '::{9C211B58-E6F1-456A-9F22-7B3B418A7BB1}'; cxShellObjectInternalRelativeVirtualPathPrefix = '::{63BE9ADB-E4B5-4623-96AA-57440B4EF5A8}'; cxShellObjectInternalVirtualPathPrefixLength = 40; cxSFGAO_GHOSTED = $00008000; // Error in ShlObj.pas {$IFNDEF DELPHI6} SID_IShellFolder2 = '{93F2F68C-1D1B-11D3-A30E-00C04F79ABD1}'; SID_IEnumExtraSearch = '{0E700BE1-9DB6-11D1-A1CE-00C04FD75D13}'; SID_IShellDetails = '{000214EC-0000-0000-C000-000000000046}'; {IShellFolder2.GetDefaultColumnState Values} SHCOLSTATE_TYPE_STR = $00000001; SHCOLSTATE_TYPE_INT = $00000002; SHCOLSTATE_TYPE_DATE = $00000003; SHCOLSTATE_TYPEMASK = $0000000F; SHCOLSTATE_ONBYDEFAULT = $00000010; // should on by default in details view SHCOLSTATE_SLOW = $00000020; // will be slow to compute; do on a background thread SHCOLSTATE_EXTENDED = $00000040; // provided by a handler; not the folder SHCOLSTATE_SECONDARYUI = $00000080; // not displayed in context menu; but listed in the "More..." dialog SHCOLSTATE_HIDDEN = $00000100; // not displayed in the UI {$EXTERNALSYM IID_IShellDetails} IID_IShellDetails: TGUID = ( D1:$000214EC; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46)); {$ENDIF} // Interface declarations, that missed in D4 and D5 versions {$IFDEF BCB} (*$HPPEMIT '#include '*) {$IFNDEF DELPHI6} (*$HPPEMIT '#if !defined(NO_WIN32_LEAN_AND_MEAN)'*) (*$HPPEMIT 'typedef struct _STRRET'*) (*$HPPEMIT '{'*) (*$HPPEMIT ' UINT uType;'*) (*$HPPEMIT ' union'*) (*$HPPEMIT ' {'*) (*$HPPEMIT ' LPWSTR pOleStr;'*) (*$HPPEMIT ' LPSTR pStr;'*) (*$HPPEMIT ' UINT uOffset;'*) (*$HPPEMIT ' char cStr[MAX_PATH];'*) (*$HPPEMIT ' } DUMMYUNIONNAME;'*) (*$HPPEMIT '} STRRET, *LPSTRRET;'*) (*$HPPEMIT '#endif'*) {$ENDIF} {$ENDIF} {$IFNDEF DELPHI6} type {$EXTERNALSYM PExtraSearch} PExtraSearch = ^TExtraSearch; {$EXTERNALSYM tagExtraSearch} tagExtraSearch = record guidSearch: TGUID; wszFriendlyName, wszMenuText: array[0..79] of WideChar; wszHelpText: array[0..MAX_PATH] of WideChar; wszUrl: array[0..2047] of WideChar; wszIcon, wszGreyIcon, wszClrIcon: array[0..MAX_PATH+10] of WideChar; end; {$EXTERNALSYM TExtraSearch} TExtraSearch = tagExtraSearch; {$EXTERNALSYM IEnumExtraSearch} IEnumExtraSearch = interface [SID_IEnumExtraSearch] function Next(celt: ULONG; out rgelt: PExtraSearch; out pceltFetched: ULONG): HResult; stdcall; function Skip(celt: ULONG): HResult; stdcall; function Reset: HResult; stdcall; function Clone(out ppEnum: IEnumExtraSearch): HResult; stdcall; end; {$EXTERNALSYM PShColumnID} PShColumnID = ^TShColumnID; {$EXTERNALSYM SHCOLUMNID} SHCOLUMNID = record fmtid: TGUID; pid: DWORD; end; {$EXTERNALSYM TShColumnID} TShColumnID = SHCOLUMNID; { IShellDetails is supported on Win9x and NT4; for >= NT5 use IShellFolder2 } _SHELLDETAILS = record fmt, cxChar: Integer; str: STRRET; end; {$EXTERNALSYM SHELLDETAILS} SHELLDETAILS = _SHELLDETAILS; TShellDetails = _SHELLDETAILS; PShellDetails = ^TShellDetails; IShellDetails = interface [SID_IShellDetails] function GetDetailsOf(pidl: PItemIDList; iColumn: UINT; var pDetails: TShellDetails): HResult; stdcall; function ColumnClick(iColumn: UINT): HResult; stdcall; end; {$EXTERNALSYM IShellFolder2} IShellFolder2 = interface(IShellFolder) [SID_IShellFolder2] function GetDefaultSearchGUID(out pguid: TGUID): HResult; stdcall; function EnumSearches(out ppEnum: IEnumExtraSearch): HResult; stdcall; function GetDefaultColumn(dwRes: DWORD; var pSort: ULONG; var pDisplay: ULONG): HResult; stdcall; function GetDefaultColumnState(iColumn: UINT; var pcsFlags: DWORD): HResult; stdcall; function GetDetailsEx(pidl: PItemIDList; const pscid: SHCOLUMNID; pv: POleVariant): HResult; stdcall; function GetDetailsOf(pidl: PItemIDList; iColumn: UINT; var psd: TShellDetails): HResult; stdcall; function MapNameToSCID(pwszName: LPCWSTR; var pscid: TShColumnID): HResult; stdcall; end; {$ENDIF} // cxShell common classes type ITEMIDLISTARRAY = array [0..MaxInt div SizeOf(PItemIDList) - 1] of PItemIDList; PITEMIDLISTARRAY = ^ITEMIDLISTARRAY; TcxBrowseFolder =(bfCustomPath, bfAltStartup, bfBitBucket, bfCommonDesktopDirectory, bfCommonDocuments, bfCommonFavorites, bfCommonPrograms, bfCommonStartMenu, bfCommonStartup, bfCommonTemplates, bfControls, bfDesktop, bfDesktopDirectory, bfDrives, bfPrinters, bfFavorites, bfFonts, bfHistory, bfMyMusic, bfMyPictures, bfNetHood, bfProfile, bfProgramFiles, bfPrograms, bfRecent, bfStartMenu, bfStartUp, bfTemplates); TcxDropEffect = (deCopy, deMove, deLink); TcxDropEffectSet = set of TcxDropEffect; TcxCustomItemProducer = class; IcxDropSource = interface(IDropSource) ['{FCCB8EC5-ABB4-4256-B34C-25E3805EA046}'] end; TcxDropSource=class(TInterfacedObject, IcxDropSource) private FOwner: TWinControl; protected function QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult; stdcall; function GiveFeedback(dwEffect: Longint): HResult; stdcall; public constructor Create(AOwner:TWinControl);virtual; property Owner:TWinControl read FOwner; end; { TcxShellOptions } TcxShellOptions = class(TPersistent) private FContextMenus: Boolean; FOwner: TWinControl; FShowFolders: Boolean; FShowToolTip: Boolean; FShowNonFolders: Boolean; FShowHidden: Boolean; FTrackShellChanges: Boolean; FOnShowToolTipChanged: TNotifyEvent; procedure SetShowFolders(Value: Boolean); procedure SetShowHidden(Value: Boolean); procedure SetShowNonFolders(Value: Boolean); procedure SetShowToolTip(Value: Boolean); procedure NotifyUpdateContents; protected property OnShowToolTipChanged: TNotifyEvent read FOnShowToolTipChanged write FOnShowToolTipChanged; public constructor Create(AOwner: TWinControl); virtual; procedure Assign(Source: TPersistent); override; function GetEnumFlags: Cardinal; property Owner: TWinControl read FOwner; published property ShowFolders: Boolean read FShowFolders write SetShowFolders default True; property ShowNonFolders: Boolean read FShowNonFolders write SetShowNonFolders default True; property ShowHidden: Boolean read FShowHidden write SetShowHidden default False; property ContextMenus: Boolean read FContextMenus write FContextMenus default True; property TrackShellChanges: Boolean read FTrackShellChanges write FTrackShellChanges default True; property ShowToolTip: Boolean read FShowToolTip write SetShowToolTip default True; end; TcxDetailItem = record Text: string; Width: Integer; Alignment: TAlignment; ID: Integer; end; TcxRequestItem = record ItemIndex: Integer; ItemProducer: TcxCustomItemProducer; Priority: Boolean; end; PcxRequestItem=^TcxRequestItem; PcxDetailItem=^TcxDetailItem; TcxShellDetails=class private FItems: TList; function GetItems(Index: Integer): PcxDetailItem; function GetCount: Integer; protected property Items:TList read FItems; public constructor Create; destructor Destroy;override; procedure ProcessDetails(ACharWidth: Integer; AShellFolder: IShellFolder; AFileSystem: Boolean); procedure Clear; function Add:PcxDetailItem; procedure Remove(Item:PcxDetailItem); property Item[Index:Integer]:PcxDetailItem read GetItems;default; property Count:Integer read GetCount; end; { TcxShellFolder } TcxShellFolderAttribute = (sfaGhosted, sfaHidden, sfaIsSlow, sfaLink, sfaReadOnly, sfaShare); TcxShellFolderAttributes = set of TcxShellFolderAttribute; TcxShellFolderCapability = (sfcCanCopy, sfcCanDelete, sfcCanLink, sfcCanMove, sfcCanRename, sfcDropTarget, sfcHasPropSheet); TcxShellFolderCapabilities = set of TcxShellFolderCapability; TcxShellFolderProperty = (sfpBrowsable, sfpCompressed, sfpEncrypted, sfpNewContent, sfpNonEnumerated, sfpRemovable); TcxShellFolderProperties = set of TcxShellFolderProperty; TcxShellFolderStorageCapability = (sfscFileSysAncestor, sfscFileSystem, sfscFolder, sfscLink, sfscReadOnly, sfscStorage, sfscStorageAncestor, sfscStream); TcxShellFolderStorageCapabilities = set of TcxShellFolderStorageCapability; TcxShellFolder = class private FAbsolutePIDL: PItemIDList; FParentShellFolder: IShellFolder; FRelativePIDL: PItemIDList; function GetAttributes: TcxShellFolderAttributes; function GetCapabilities: TcxShellFolderCapabilities; function GetDisplayName: string; function GetIsFolder: Boolean; function GetPathName: string; function GetProperties: TcxShellFolderProperties; function GetShellAttributes(ARequestedAttributes: LongWord): LongWord; function GetShellFolder: IShellFolder; function GetStorageCapabilities: TcxShellFolderStorageCapabilities; function GetSubFolders: Boolean; function HasShellAttribute(AAttribute: LongWord): Boolean; overload; function HasShellAttribute(AAttributes, AAttribute: LongWord): Boolean; overload; function InternalGetDisplayName(AFolder: IShellFolder; APIDL: PItemIDList; ANameType: DWORD): string; public constructor Create(AAbsolutePIDL: PItemIDList); destructor Destroy; override; property Attributes: TcxShellFolderAttributes read GetAttributes; property Capabilities: TcxShellFolderCapabilities read GetCapabilities; property IsFolder: Boolean read GetIsFolder; property Properties: TcxShellFolderProperties read GetProperties; property StorageCapabilities: TcxShellFolderStorageCapabilities read GetStorageCapabilities; property SubFolders: Boolean read GetSubFolders; property AbsolutePIDL: PItemIDList read FAbsolutePIDL; property DisplayName: string read GetDisplayName; property ParentShellFolder: IShellFolder read FParentShellFolder; property PathName: string read GetPathName; property RelativePIDL: PItemIDList read FRelativePIDL; property ShellFolder: IShellFolder read GetShellFolder; end; TcxCustomShellRoot=class(TPersistent) private FAttributes: Cardinal; FBrowseFolder: TcxBrowseFolder; FCustomPath: WideString; FFolder: TcxShellFolder; FIsRootChecking: Boolean; FOwner: TPersistent; FParentWindow: HWND; FPidl: PItemIDList; FRootChangingCount: Integer; FShellFolder: IShellFolder; FUpdating: Boolean; FValid: Boolean; FOnSettingsChanged: TNotifyEvent; procedure SetBrowseFolder(Value: TcxBrowseFolder); procedure SetCustomPath(const Value: WideString); procedure SetPidl(const Value: PItemIDList); function GetCurrentPath: WideString; procedure UpdateFolder; protected procedure CheckRoot; virtual; procedure DoSettingsChanged; procedure RootUpdated; virtual; property Owner: TPersistent read FOwner; property ParentWindow: HWND read FParentWindow; public constructor Create(AOwner: TPersistent; AParentWindow: HWND); virtual; destructor Destroy;override; procedure Assign(Source: TPersistent); override; procedure Update(ARoot: TcxCustomShellRoot); property Attributes:Cardinal read FAttributes; property CurrentPath:WideString read GetCurrentPath; property Folder: TcxShellFolder read FFolder; property IsValid:Boolean read FValid; property Pidl:PItemIDList read FPidl write SetPidl; property ShellFolder:IShellFolder read FShellFolder; property OnSettingsChanged: TNotifyEvent read FOnSettingsChanged write FOnSettingsChanged; published property BrowseFolder:TcxBrowseFolder read FBrowseFolder write SetBrowseFolder default bfDesktop; property CustomPath:WideString read FCustomPath write SetCustomPath; end; TcxRootChangedEvent=procedure (Sender:TObject; Root:TcxCustomShellRoot) of object; TcxShellItemInfo = class private FCanRename: Boolean; FDetails: TStrings; FFolder: TcxShellFolder; FFullPIDL: PItemIDList; FHasSubfolder: Boolean; FIconIndex: Integer; FInfoTip: WideString; FInitialized: Boolean; FIsDropTarget: Boolean; FIsFilesystem: Boolean; FIsFolder: Boolean; FIsGhosted: Boolean; FIsLink: Boolean; FIsRemovable: Boolean; FIsShare: Boolean; FItemProducer: TcxCustomItemProducer; FName: WideString; FOpenIconIndex: Integer; Fpidl: PItemIDList; FUpdated: Boolean; FUpdating: Boolean; protected property Updating:Boolean read FUpdating write FUpdating; public constructor Create(AItemProducer: TcxCustomItemProducer; AParentIFolder: IShellFolder; AParentPIDL, APIDL: PItemIDList; AFast: Boolean); virtual; destructor Destroy;override; procedure CheckUpdate(ShellFolder:IShellFolder;FolderPidl:PItemIDList;Fast:Boolean); procedure CheckInitialize(AIFolder: IShellFolder; APIDL: PItemIDList); procedure FetchDetails(wnd:HWND;ShellFolder:IShellFolder;DetailsMap:TcxShellDetails); procedure CheckSubitems(AParentIFolder: IShellFolder; AEnumSettings: Cardinal); procedure SetNewPidl(pFolder:IShellFolder;FolderPidl,apidl:PItemIDList); property CanRename:Boolean read FCanRename; property Details:TStrings read FDetails; property Folder: TcxShellFolder read FFolder; property FullPIDL: PItemIDList read FFullPIDL; property HasSubfolder:Boolean read FHasSubfolder; property IconIndex:Integer read FIconIndex; property InfoTip:WideString read FInfoTip; property Initialized:Boolean read FInitialized; property IsDropTarget:Boolean read FIsDropTarget; property IsFilesystem:Boolean read FIsFilesystem; property IsFolder:Boolean read FIsFolder; property IsGhosted:Boolean read FIsGhosted; property IsLink:Boolean read FIsLink; property IsRemovable:Boolean read FIsRemovable; property IsShare:Boolean read FIsShare; property ItemProducer: TcxCustomItemProducer read FItemProducer; property Name:WideString read FName; property OpenIconIndex:Integer read FOpenIconIndex; property pidl:PItemIDList read Fpidl; property Updated:Boolean read FUpdated write FUpdated; end; PcxShellItemInfo = TcxShellItemInfo; { TcxShellItemsInfoGatherer } TcxShellItemsInfoGatherer = class private FFetchQueue: TList; FFetchStoppedEvent: THandle; FFetchThread: THandle; FIsFetchQueueClearing: Boolean; FOwner: TWinControl; FStopFetchCount: Integer; FStopFetchEvent: THandle; FTerminateFetchThreadEvent: THandle; procedure CreateFetchThread; function CreateRequestItem(AItemProducer: TcxCustomItemProducer; AIndex: Integer; APriority: Boolean): PcxRequestItem; function GetFetchQueueItemIndex(AFetchQueue: TList; AItemProducer: TcxCustomItemProducer; AIndex: Integer): Integer; function GetIsFetchStopping: Boolean; function GetIsFetchThreadTerminating: Boolean; procedure FetchResumed; procedure FetchStopped; procedure InternalCloseHandle(var AHandle: THandle); procedure TerminateFetchThread; property FetchQueue: TList read FFetchQueue; property IsFetchStopping: Boolean read GetIsFetchStopping; property IsFetchThreadTerminating: Boolean read GetIsFetchThreadTerminating; protected procedure DestroyFetchThread; public constructor Create(AOwner: TWinControl); destructor Destroy; override; procedure ClearFetchQueue(AItemProducer: TcxCustomItemProducer); procedure RequestItemInfo(AItemProducer: TcxCustomItemProducer; AIndex: Integer; APriority: Boolean); procedure ResumeFetch; procedure StopFetch; end; TcxCustomItemProducer = class private FDetails: TcxShellDetails; FFolderPidl: PItemIDList; FItems: TList; FItemsLock: TMultiReadExclusiveWriteSynchronizer; FOwner: TWinControl; FShellFolder: IShellFolder; protected function AllowBackgroundProcessing: Boolean; virtual; abstract; function CanAddFolder(AFolder: TcxShellFolder): Boolean; virtual; function DoCompareItems(AItem1, AItem2: TcxShellFolder; out ACompare: Integer): Boolean; virtual; procedure DoSort; virtual; procedure FetchItems(APreloadItems: Integer); function GetEnumFlags: Cardinal; virtual; abstract; function GetItemsInfoGatherer: TcxShellItemsInfoGatherer; virtual; abstract; function GetShowToolTip: Boolean; virtual; abstract; procedure InitializeItem(Item: TcxShellItemInfo); virtual; procedure CheckForSubitems(AItem: TcxShellItemInfo); virtual; procedure ClearFetchQueue; property ItemsLock: TMultiReadExclusiveWriteSynchronizer read FItemsLock; property ShellFolder: IShellFolder read FShellFolder; property FolderPidl: PItemIDList read FFolderPidl write FFolderPidl; property Owner: TWinControl read FOwner; public constructor Create(AOwner: TWinControl); virtual; destructor Destroy; override; procedure ProcessItems(AIFolder: IShellFolder; AFolderPIDL: PItemIDList; cPreloadItems: Integer); virtual; procedure ProcessDetails(ShellFolder: IShellFolder; CharWidth: Integer); virtual; procedure FetchRequest(AIndex: Integer; APriority: Boolean = False); procedure ClearItems; procedure LockRead; procedure LockWrite; procedure UnlockRead; procedure UnlockWrite; procedure RequestItemsInfo; procedure SetItemsCount(Count: Integer); virtual; procedure NotifyUpdateItem(AItem: PcxRequestItem); virtual; abstract; procedure NotifyRemoveItem(Index: Integer); virtual; procedure NotifyAddItem(Index: Integer); virtual; procedure DoGetInfoTip(Handle: HWND; ItemIndex: Integer; InfoTip: PChar; cch: Integer); function GetItemByPidl(APidl: PItemIDList): TcxShellItemInfo; function GetItemIndexByPidl(APidl: PItemIDList): Integer; procedure Sort; property Details: TcxShellDetails read FDetails; property Items: TList read FItems; property ItemsInfoGatherer: TcxShellItemsInfoGatherer read GetItemsInfoGatherer; end; TcxDragDropSettings = class(TPersistent) private FAllowDragObjects: Boolean; FDefaultDropEffect: TcxDropEffect; FDropEffect: TcxDropEffectSet; FScroll: Boolean; FOnChange: TNotifyEvent; function GetDefaultDropEffectAPI: Integer; function GetDropEffectAPI: DWORD; procedure SetAllowDragObjects(Value: Boolean); protected procedure Changed; public property DropEffectAPI: DWORD read GetDropEffectApi; property DefaultDropEffectAPI: Integer read GetDefaultDropEffectAPI; constructor Create; property OnChange: TNotifyEvent read FOnChange write FOnChange; published property AllowDragObjects: Boolean read FAllowDragObjects write SetAllowDragObjects default True; property DefaultDropEffect: TcxDropEffect read FDefaultDropEffect write FDefaultDropEffect default deMove; property DropEffect: TcxDropEffectSet read FDropEffect write FDropEffect default [deCopy, deMove, deLink]; property Scroll: Boolean read FScroll write FScroll stored False; // deprecated end; TShChangeNotifyEntry = packed record pidlPath: PItemIDList; bWatchSubtree: BOOL; end; DWORDITEMID=record cb: SHORT; dwItem1: DWORD; dwItem2: DWORD; end; PDWORDITEMID=^DWORDITEMID; PShChangeNotifyEntry = ^TShChangeNotifyEntry; function GetDesktopIShellFolder: IShellFolder; function GetTextFromStrRet(var AStrRet: TStrRet; APIDL: PitemIDList): WideString; function GetShellDetails(pFolder:IShellFolder;pidl:PItemIDList;out sd:IShellDetails):Hresult; function HasSubItems(AParentIFolder: IShellFolder; AFullPIDL: PItemIDList; AEnumSettings: Cardinal): Boolean; function cxGetFolderLocation(AWnd: HWND; ACSIDL: Integer; AToken: THandle; AReserwed: DWORD; var APIDL: PItemIDList): HRESULT; function cxFileTimeToDateTime(fTime:FILETIME):TDateTime; function cxMalloc: IMalloc; procedure DisplayContextMenu(AWnd: HWND; AIFolder: IShellFolder; AItemPIDLList: TList; const APos: TPoint); { Pidl Tools} function GetPidlItemsCount(APidl: PItemIDList): Integer; function GetPidlSize(APidl: PItemIDList): Integer; function GetNextItemID(APidl: PItemIDList): PItemIDList; function GetPidlCopy(APidl: PItemIDList): PItemIDList; function GetLastPidlItem(APidl: PItemIDList): PItemIDList; function GetPidlName(APIDL: PItemIDList): WideString; function ConcatenatePidls(pidl1,pidl2:PItemIDList):PItemIDList; procedure DisposePidl(APidl: PItemIDList); function GetPidlParent(pidl:PItemIDList):PItemIDList; function CreateEmptyPidl:PItemIDList; function CreatePidlListFromList(List:TList):PItemIDList; function ExtractParticularPidl(APidl: PItemIDList): PItemIDList; function EqualPIDLs(APIDL1, APIDL2: PItemIDList): Boolean; function IsSubPath(APIDL1, APIDL2: PItemIDList): Boolean; { Unicode Tools } procedure StrPLCopyW(Dest:PWideChar;Source:WideString;MaxLen:Cardinal); function StrPasW(Source:PWideChar):WideString; function StrLenW(Source:PWideChar):Cardinal; function UpperCaseW(Source:WideString):WideString; function LowerCaseW(Source:WideString):WideString; procedure CheckShellRoot(ARoot: TcxCustomShellRoot); function GetShellItemDisplayName(AIFolder: IShellFolder; APIDL: PItemIDList; ACheckIsFolder: Boolean): WideString; function cxShellGetThreadSafeFileInfo(pszPath: PChar; dwFileAttributes: DWORD; var psfi: TSHFileInfo; cbFileInfo, uFlags: UINT): DWORD; stdcall; const DSM_SETCOUNT = CM_BASE + 315; DSM_NOTIFYUPDATE = CM_BASE + 316; DSM_NOTIFYREMOVEITEM = CM_BASE + 318; DSM_NOTIFYADDITEM = CM_BASE + 319; DSM_NOTIFYUPDATECONTENTS = CM_BASE + 320; DSM_SHELLCHANGENOTIFY = CM_BASE + 321; DSM_DONAVIGATE = CM_BASE + 322; DSM_SYNCHRONIZEROOT = CM_BASE + 323; DSM_SHELLTREECHANGENOTIFY = CM_BASE + 324; DSM_SHELLTREERESTORECURRENTPATH = CM_BASE + 325; DSM_SYSTEMSHELLCHANGENOTIFY = CM_BASE + 326; PRELOAD_ITEMS_COUNT = 10; SHCNF_ACCEPT_INTERRUPTS = $1; SHCNF_ACCEPT_NON_INTERRUPTS = $2; SHCNF_NO_PROXY = $8000; type TPidlList = array [0..1] of PItemIDList; PPidlList = ^TPidlList; var SHChangeNotifyRegister: function (hwnd: HWND; dwFlags: DWORD; wEventMask: DWORD; uMsg: UINT; cItems: DWORD; lpItems: PShChangeNotifyEntry): Cardinal; stdcall; SHChangeNotifyUnregister: function (hNotify: Cardinal): Boolean; stdcall; SHChangeNotification_Lock: function (hChange: Cardinal; dwProcId: DWORD; var PPidls: PPidlList; var plEvent: Longint): Cardinal; stdcall; SHChangeNotification_UnLock: function (hLock: Cardinal): BOOL; stdcall; implementation uses cxContainer, cxControls, cxEdit, dxUxTheme, dxCore; const ShellLibraryName = 'shell32.dll'; {$IFNDEF DELPHI6} PathDelim = '\'; cxIID_IShellFolder2: TGUID = ( D1:$93F2F68C; D2:$1D1B; D3:$11D3; D4:($A3,$0E,$00,$C0,$4F,$79,$AB,$D1)); {$ENDIF} SFGAO_ENCRYPTED = $00002000; SFGAO_ISSLOW = $00004000; SFGAO_STORAGE = $00000008; SFGAO_STORAGEANCESTOR = $00800000; SFGAO_STORAGECAPMASK = $70C50008; SFGAO_STREAM = $00400000; type TcxContextMenuMessageWindow = class(TcxMessageWindow) private FContextMenu: IContextMenu2; protected procedure WndProc(var Message: TMessage); override; public property ContextMenu: IContextMenu2 read FContextMenu write FContextMenu; end; TSHGetPathFromIDList = function(APIDL: PItemIDList; APath: PChar): BOOL; stdcall; TSHGetPathFromIDListW = function(APIDL: PItemIDList; APath: PWideChar): BOOL; stdcall; {$IFDEF DELPHI6} cxIShellFolder2 = interface(IShellFolder2) ['{93F2F68C-1D1B-11D3-A30E-00C04F79ABD1}'] end; {$ENDIF} var FComInitializationSucceeded: Boolean; FSysFileIconIndex: Integer = -1; FSysFolderIconIndex: Integer = -1; FSysFolderOpenIconIndex: Integer = -1; cxSHGetFolderLocation: function (wnd: HWND; nFolder: Integer; hToken: THandle; dwReserwed: DWORD; var ppidl: PItemIDList): HResult; stdcall; cxSHGetPathFromIDList: TSHGetPathFromIDList = nil; cxSHGetPathFromIDListW: TSHGetPathFromIDListW = nil; ShellLibrary: HMODULE = 0; FcxMalloc: IMalloc; FShellItemsInfoGatherers: TList; FShellLock: TCriticalSection; (*function GetShellItemDisplayName(AIFolder: IShellFolder; APIDL: PItemIDList; ACheckIsFolder: Boolean): WideString; var AAttributes, AFlags: Cardinal; AIsFolder: Boolean; AStrRet: TStrRet; begin Result := ''; if ACheckIsFolder then begin AAttributes := SFGAO_FOLDER; if not Succeeded(AIFolder.GetAttributesOf(1, APIDL, AAttributes)) then Exit; AIsFolder := AAttributes and SFGAO_FOLDER <> 0; end else AIsFolder := False; AFlags := SHGDN_INFOLDER; if AIsFolder then AFlags := AFlags or SHGDN_FORPARSING; if not Succeeded(AIFolder.GetDisplayNameOf(APIDL, AFlags, AStrRet)) then Exit; Result := GetTextFromStrRet(AStrRet, APIDL); if AIsFolder and (Length(Result) > 2) then if (Result[1] = ':') and (Result[2] = ':') or (Result[1] = '\') and (Result[2] = '\') then begin AIFolder.GetDisplayNameOf(APIDL, SHGDN_INFOLDER, AStrRet); Result := GetTextFromStrRet(AStrRet, APIDL); end; end;*) procedure CheckShellRoot(ARoot: TcxCustomShellRoot); begin if ARoot.ShellFolder = nil then ARoot.CheckRoot; end; function GetShellItemDisplayName(AIFolder: IShellFolder; APIDL: PItemIDList; ACheckIsFolder: Boolean): WideString; var AStrRet: TStrRet; begin if Succeeded(AIFolder.GetDisplayNameOf(APIDL, SHGDN_INFOLDER, AStrRet)) then Result := GetTextFromStrRet(AStrRet, APIDL) else Result := ''; end; function cxShellGetThreadSafeFileInfo(pszPath: PChar; dwFileAttributes: DWORD; var psfi: TSHFileInfo; cbFileInfo, uFlags: UINT): DWORD; begin FShellLock.Enter; Result := SHGetFileInfo(pszPath, dwFileAttributes, psfi, cbFileInfo, uFlags); FShellLock.Leave; end; function HasSubItems(AParentIFolder: IShellFolder; AFullPIDL: PItemIDList; AEnumSettings: Cardinal): Boolean; function HasAttributes(AAttributes: UINT): Boolean; var ATempAttributes: UINT; ATempPIDL: PItemIDList; begin ATempAttributes := AAttributes; ATempPIDL := GetLastPidlItem(AFullPIDL); AParentIFolder.GetAttributesOf(1, ATempPIDL, ATempAttributes); Result := ATempAttributes and AAttributes = AAttributes; end; function CheckLocalFolder(out AHasSubItems: Boolean): Boolean; var AAttributes, AParsedCharCount: ULONG; ADesktopIFolder: IShellFolder; AFileSearchAttributes: Integer; ATempPIDL: PItemIDList; ASearchRec: TSearchRec; S: WideString; begin Result := False; S := GetPidlName(AFullPIDL); if (S = '')(* or (Pos('\\', S) = 1)*) then Exit; SHGetDesktopFolder(ADesktopIFolder); AAttributes := 0; ADesktopIFolder.ParseDisplayName(0, nil, PWideChar(S), AParsedCharCount, ATempPIDL, AAttributes); if ATempPIDL = nil then Exit; try Result := True; AHasSubItems := False; AFileSearchAttributes := faReadOnly or faSysFile or faArchive; if AEnumSettings and SHCONTF_FOLDERS <> 0 then AFileSearchAttributes := AFileSearchAttributes or faDirectory; if AEnumSettings and SHCONTF_INCLUDEHIDDEN <> 0 then AFileSearchAttributes := AFileSearchAttributes or faHidden; if S[Length(S)] = PathDelim then Delete(S, Length(S), 1); if FindFirst(S + PathDelim + '*.*', AFileSearchAttributes, ASearchRec) = 0 then begin repeat if (ASearchRec.Name = '.') or (ASearchRec.Name = '..') then begin if FindNext(ASearchRec) <> 0 then Break; end else begin AHasSubItems := True; Break; end; until False; FindClose(ASearchRec); end; finally DisposePidl(ATempPIDL); end; end; var ATempIFolder: IShellFolder; ATempPIDL: PItemIDList; AIEnum: IEnumIDList; AFetchedItemCount: Cardinal; begin Result := HasAttributes(SFGAO_FOLDER); if Result then if AEnumSettings and SHCONTF_NONFOLDERS = 0 then Result := HasAttributes(SFGAO_HASSUBFOLDER) else if not CheckLocalFolder(Result) then begin Result := HasAttributes(SFGAO_HASSUBFOLDER); if not Result and Succeeded(AParentIFolder.BindToObject( GetLastPidlItem(AFullPIDL), nil, IID_IShellFolder, ATempIFolder)) and (ATempIFolder <> nil) and Succeeded(ATempIFolder.EnumObjects(0, AEnumSettings, AIEnum)) and Assigned(AIEnum) and (AIEnum.Next(1, ATempPIDL, AFetchedItemCount) = S_OK) then try Result := AFetchedItemCount = 1; finally DisposePidl(ATempPIDL); end; end; end; function GetDesktopIShellFolder: IShellFolder; begin OleCheck(SHGetDesktopFolder(Result)); end; function GetTextFromStrRet(var AStrRet: TStrRet; APIDL: PitemIDList): WideString; var P: PChar; ATmp: PChar; begin case AStrRet.uType of STRRET_CSTR: begin ATmp := PChar(dxAnsiStringToString(AStrRet.cStr)); SetString(Result, ATmp, lstrlen(ATmp)); end; STRRET_OFFSET: begin P := @APIDL.mkid.abID; Inc(P, AStrRet.uOffset - SizeOf(APIDL.mkid.cb)); SetString(Result, P, APIDL.mkid.cb - AStrRet.uOffset); end; STRRET_WSTR: begin Result := StrPasW(AStrRet.pOleStr); cxMalloc.Free(AStrRet.pOleStr); end; end; end; function GetShellDetails(pFolder:IShellFolder;pidl:PItemIDList;out sd:IShellDetails):Hresult; begin try Result := pFolder.QueryInterface(IID_IShellDetails, sd); if Result = S_OK then Exit; Result:=pFolder.GetUIObjectOf(0,0,pidl,IID_IShellDetails,nil,sd); if Result = S_OK then Exit; Result:=pFolder.CreateViewObject(0,IID_IShellDetails,sd); if Result = S_OK then Exit; Result:=pFolder.GetUIObjectOf(0,Integer(pidl<>nil)(*1*),pidl,IID_IShellDetails,nil,sd); finally if sd = nil then Result := E_NOINTERFACE; end; end; function cxGetFolderLocation(AWnd: HWND; ACSIDL: Integer; AToken: THandle; AReserwed: DWORD; var APIDL: PItemIDList): HRESULT; begin if Win32MajorVersion < 5 then Result := SHGetSpecialFolderLocation(AWnd, ACSIDL, APIDL) else Result := cxSHGetFolderLocation(AWnd, ACSIDL, AToken, AReserwed, APIDL); end; function cxFileTimeToDateTime(fTime:FILETIME):TDateTime; var LocalTime:TFileTime; Age:Integer; begin FileTimeToLocalFileTime(FTime,LocalTime); if FileTimeToDosDateTime(LocalTime,LongRec(Age).Hi,LongRec(Age).Lo) then Result:=FileDateToDateTime(Age) else Result:=-1; end; function cxMalloc: IMalloc; begin if FcxMalloc = nil then SHGetMalloc(FcxMalloc); Result := FcxMalloc; end; procedure TcxContextMenuMessageWindow.WndProc(var Message: TMessage); begin case Message.Msg of WM_INITMENUPOPUP: begin ContextMenu.HandleMenuMsg(Message.Msg, Message.wParam, Message.lParam); Message.Result := 0; end; WM_DRAWITEM, WM_MEASUREITEM: begin ContextMenu.HandleMenuMsg(Message.Msg, Message.wParam, Message.lParam); Message.Result := 1; end; else inherited WndProc(Message); end; end; function CreateCallbackWnd(AContextMenu: IContextMenu2): TcxContextMenuMessageWindow; begin Result := TcxContextMenuMessageWindow.Create; Result.ContextMenu := AContextMenu; end; procedure DisplayContextMenu(AWnd: HWND; AIFolder: IShellFolder; AItemPIDLList: TList; const APos: TPoint); var ACallbackWnd: TcxContextMenuMessageWindow; ACmd: Longbool; AContextMenu: IContextMenu; AContextMenu2: IContextMenu2; AInvokeCommandInfo: TCMInvokeCommandInfo; AMenu: HMENU; APIDLList: PItemIDList; begin if (AIFolder = nil) or (AItemPIDLList.Count = 0) then Exit; APIDLList := CreatePidlListFromList(AItemPIDLList); try if Failed(AIFolder.GetUIObjectOf(AWnd, AItemPIDLList.Count, PItemIDList(APIDLList^), IID_IContextMenu, nil, AContextMenu)) then Exit; AMenu := CreatePopupMenu; ACallbackWnd := nil; if AMenu <> 0 then try if Failed(AContextMenu.QueryContextMenu(AMenu, 0, 1, $7FFF, CMF_NORMAL)) then Exit; if Succeeded(AContextMenu.QueryInterface(IID_IContextMenu2, AContextMenu2)) then ACallbackWnd := CreateCallbackWnd(AContextMenu2); if ACallbackWnd <> nil then ACmd := TrackPopupMenu(AMenu, TPM_LEFTALIGN or TPM_LEFTBUTTON or TPM_RIGHTBUTTON or TPM_RETURNCMD, APos.X, APos.Y, 0, ACallbackWnd.Handle, nil) else ACmd := TrackPopupMenu(AMenu, TPM_LEFTALIGN or TPM_LEFTBUTTON or TPM_RIGHTBUTTON or TPM_RETURNCMD, APos.X, APos.Y, 0, AWnd, nil); if ACmd then begin ZeroMemory(@AInvokeCommandInfo, SizeOf(AInvokeCommandInfo)); AInvokeCommandInfo.cbSize := SizeOf(AInvokeCommandInfo); AInvokeCommandInfo.hwnd := AWnd; AInvokeCommandInfo.lpVerb := MakeIntResourceA(Longint(ACmd) - 1); AInvokeCommandInfo.nShow := SW_SHOWNORMAL; AContextMenu.InvokeCommand(AInvokeCommandInfo); end; finally DestroyMenu(AMenu); FreeAndNil(ACallbackWnd); end; finally DisposePidl(APIDLList); end; end; function SysFileIconIndex: Integer; var AFileInfo: TSHFileInfo; begin if FSysFileIconIndex = -1 then begin cxShellGetThreadSafeFileInfo('C:\CXDUMMYFILE.TXT', FILE_ATTRIBUTE_NORMAL, AFileInfo, SizeOf(AFileInfo), SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES); FSysFileIconIndex := AFileInfo.iIcon; end; Result := FSysFileIconIndex; end; function SysFolderIconIndex: Integer; var AFileInfo: TSHFileInfo; begin if FSysFolderIconIndex = -1 then begin cxShellGetThreadSafeFileInfo('C:\CXDUMMYFOLDER', FILE_ATTRIBUTE_DIRECTORY, AFileInfo, SizeOf(AFileInfo), SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES); FSysFolderIconIndex := AFileInfo.iIcon; end; Result := FSysFolderIconIndex; end; function SysFolderOpenIconIndex: Integer; var AFileInfo: TSHFileInfo; begin if FSysFolderOpenIconIndex = -1 then begin cxShellGetThreadSafeFileInfo('C:\CXDUMMYFOLDER', FILE_ATTRIBUTE_DIRECTORY, AFileInfo, SizeOf(AFileInfo), SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES or SHGFI_OPENICON); FSysFolderOpenIconIndex := AFileInfo.iIcon; end; Result := FSysFolderOpenIconIndex; end; { Unicode Tools } function UpperCaseW(Source:WideString):WideString; begin Result:=AnsiUpperCase(Source); end; function LowerCaseW(Source:WideString):WideString; begin Result:=AnsiLowerCase(Source); end; function StrLenW(Source: PWideChar): Cardinal; asm MOV EDX, EDI MOV EDI, EAX MOV ECX, 0FFFFFFFFH XOR AX, AX REPNE SCASW MOV EAX, 0FFFFFFFEH SUB EAX, ECX MOV EDI, EDX end; function StrPasW(Source:PWideChar):WideString; var StringLength:Cardinal; begin StringLength:=StrLenW(Source); SetLength(Result,StringLength); CopyMemory(Pointer(Result),Source,StringLength*2); end; procedure StrPLCopyW(Dest:PWideChar;Source:WideString;MaxLen:Cardinal); begin lstrcpynw(Dest,PWideChar(Source),MaxLen); end; { PidlTools} function GetPidlParent(pidl:PItemIDList):PItemIDList; var SourceSize:Integer; PrevPidl:PItemIDList; InitialPidl:PItemIDList; TempPidl:PItemIDList; begin Result:=nil; SourceSize:=0; InitialPidl:=pidl; PrevPidl:=nil; if pidl<>nil then begin while pidl.mkid.cb<>0 do begin Inc(SourceSize,pidl.mkid.cb); PrevPidl:=pidl; pidl:=GetNextItemID(pidl); end; if SourceSize>0 then Dec(SourceSize,PrevPidl.mkid.cb); Result:=cxMalloc.Alloc(SourceSize+SizeOf(SHITEMID)); CopyMemory(Result,InitialPidl,SourceSize); TempPidl:=Pointer(Integer(Result)+SourceSize); TempPidl.mkid.cb:=0; TempPidl.mkid.abID[0]:=0; end; end; function CreateEmptyPidl:PItemIDList; begin Result:=cxMalloc.Alloc(SizeOf(ITEMIDLIST)); Result.mkid.cb:=0; Result.mkid.abID[0]:=0; end; function CreatePidlListFromList(List:TList):PItemIDList; var i:Integer; tempResult:PITEMIDLISTARRAY; begin Result:=nil; if List=nil then Exit; tempResult:=cxMalloc.Alloc(List.Count*SizeOf(ITEMIDLIST)); for i:=0 to List.Count-1 do tempResult[i]:=List[i]; Result:=Pointer(tempResult); end; function ExtractParticularPidl(APidl: PItemIDList): PItemIDList; var ATemp: PItemIDList; begin Result := nil; if (APidl <> nil) and (APidl.mkid.cb <> 0) then begin Result := cxMalloc.Alloc(APidl.mkid.cb + SizeOf(SHITEMID)); CopyMemory(Result, APidl, APidl.mkid.cb + SizeOf(SHITEMID)); ATemp := GetNextItemID(Result); ATemp.mkid.cb := 0; ATemp.mkid.abID[0] := 0; end; end; function EqualPIDLs(APIDL1, APIDL2: PItemIDList): Boolean; var L1, L2: Integer; begin Result := APIDL1 = APIDL2; if not Result then if (APIDL1 = nil) or (APIDL2 = nil) then Exit else begin L1 := GetPidlSize(APIDL1); L2 := GetPidlSize(APIDL2); Result := (L1 = L2) and CompareMem(APIDL1, APIDL2, L1); end; end; function IsSubPath(APIDL1, APIDL2: PItemIDList): Boolean; // TODO var L1, L2: Integer; begin L1 := GetPidlSize(APIDL1); L2 := GetPidlSize(APIDL2); Result := (L1 = 0) or (L2 >= L1) and CompareMem(APIDL1, APIDL2, L1); end; function ConcatenatePidls(pidl1,pidl2:PItemIDList):PItemIDList; var cb1,cb2:Integer; begin if (pidl1=nil) and (pidl2=nil) then Result:=nil else if pidl1=nil then Result:=GetPidlCopy(pidl2) else if pidl2=nil then Result:=GetPidlCopy(pidl1) else begin cb1:=GetPidlSize(pidl1); cb2:=GetPidlSize(pidl2)+SizeOf(SHITEMID); Result:=cxMalloc.Alloc(cb1+cb2); if Result<>nil then begin CopyMemory(Result,pidl1,cb1); CopyMemory(Pointer(Integer(Result)+cb1),pidl2,cb2); end; end; end; function GetPidlName(APIDL: PItemIDList): WideString; var P: PChar; PW: PWideChar; begin Result := ''; if APIDL = nil then Exit; if not Assigned(cxSHGetPathFromIDListW) then begin GetMem(P, MAX_PATH + 1); try cxSHGetPathFromIDList(APIDL, P); Result := StrPas(P); finally FreeMem(P); end; end else begin GetMem(PW, (MAX_PATH + 1) * 2); try cxSHGetPathFromIDListW(APIDL, PW); Result := StrPasW(PW); finally FreeMem(PW); end; end; end; function GetLastPidlItem(APidl: PItemIDList): PItemIDList; var ATempPidl: PItemIDList; begin Result := APidl; if APidl <> nil then begin ATempPidl := APidl; while ATempPidl.mkid.cb <> 0 do begin Result := ATempPidl; ATempPidl := GetNextItemID(ATempPidl); end; end; end; procedure DisposePidl(APidl: PItemIDList); begin if APidl <> nil then cxMalloc.Free(APidl); end; function GetPidlCopy(APidl: PItemIDList): PItemIDList; var ASize: Integer; begin Result := nil; if APidl <> nil then begin ASize := GetPidlSize(APidl) + SizeOf(SHITEMID); Result := cxMalloc.Alloc(ASize); CopyMemory(Result, APidl, ASize); end; end; function GetPidlItemsCount(APidl: PItemIDList): Integer; begin Result := 0; if APidl <> nil then while APidl.mkid.cb <> 0 do begin Inc(Result); APidl := GetNextItemID(APidl); if Result > MAX_PATH then begin Result := -1; Break; end; end; end; function GetPidlSize(APidl: PItemIDList):Integer; begin Result := 0; while (APidl <> nil) and (APidl.mkid.cb <> 0) do begin Inc(Result, APidl.mkid.cb); APidl := GetNextItemID(APidl); end; end; function GetNextItemID(APidl: PItemIDList): PItemIDList; begin Result := nil; if (APidl <> nil) and (APidl.mkid.cb <> 0) then Result := PItemIDList(Integer(APidl) + APidl.mkid.cb); end; function cxShellItemsInfoGathererFetchThreadFunction( AItemsInfoGatherer: TcxShellItemsInfoGatherer): Integer; stdcall; function CanProcessFetchQueueItems: Boolean; begin Result := not AItemsInfoGatherer.IsFetchThreadTerminating and not AItemsInfoGatherer.IsFetchStopping; end; procedure ProcessFetchQueueItem(AItem: PcxRequestItem); var AItemData: TcxShellItemInfo; AItemProducer: TcxCustomItemProducer; begin AItemProducer := AItem^.ItemProducer; AItemProducer.LockRead; try if AItem^.ItemIndex >= AItemProducer.Items.Count then Exit; AItemData := AItemProducer.Items[AItem^.ItemIndex]; AItemData.CheckUpdate(AItemProducer.ShellFolder, AItemProducer.FolderPidl, False); AItemProducer.CheckForSubItems(AItemData); AItemData.Updated := True; finally AItem^.ItemProducer.UnlockRead; end; AItemProducer.NotifyUpdateItem(AItem); end; procedure ProcessFetchQueueItems; var AFetchQueue: TList; begin AFetchQueue := AItemsInfoGatherer.FetchQueue; while AFetchQueue.Count <> 0 do begin ProcessFetchQueueItem(PcxRequestItem(AFetchQueue[0])); Dispose(AFetchQueue[0]); AFetchQueue.Delete(0); if not CanProcessFetchQueueItems then Break; end; end; const cxShellItemsInfoGathererSleepPause = 10; var ASucceeded: Boolean; begin Result := 0; ASucceeded := Succeeded(CoInitializeEx(nil, COINIT_APARTMENTTHREADED)); try try repeat if CanProcessFetchQueueItems then begin AItemsInfoGatherer.FetchResumed; if AItemsInfoGatherer.FetchQueue.Count <> 0 then ProcessFetchQueueItems; end; if AItemsInfoGatherer.IsFetchThreadTerminating then Break; if AItemsInfoGatherer.IsFetchStopping then AItemsInfoGatherer.FetchStopped; Sleep(cxShellItemsInfoGathererSleepPause); until False; except end; finally if ASucceeded then CoUninitialize; end; end; procedure RegisterShellItemsInfoGatherer(AGatherer: TcxShellItemsInfoGatherer); begin if FShellItemsInfoGatherers = nil then FShellItemsInfoGatherers := TList.Create; FShellItemsInfoGatherers.Add(AGatherer); end; procedure UnregisterShellItemsInfoGatherer(AGatherer: TcxShellItemsInfoGatherer); begin FShellItemsInfoGatherers.Remove(AGatherer); if FShellItemsInfoGatherers.Count = 0 then FreeAndNil(FShellItemsInfoGatherers); end; { TcxCustomShellRoot } procedure TcxCustomShellRoot.CheckRoot; const CSIDL_MYMUSIC = $0D; CSIDL_PROGRAM_FILES = $26; CSIDL_MYPICTURES = $27; CSIDL_PROFILE = $28; CSIDL_COMMON_TEMPLATES = $2D; CSIDL_COMMON_DOCUMENTS = $2E; ACSIDLs: array[TcxBrowseFolder] of Integer = ( CSIDL_DESKTOP, CSIDL_STARTUP, CSIDL_BITBUCKET, CSIDL_COMMON_DESKTOPDIRECTORY, CSIDL_COMMON_DOCUMENTS, CSIDL_COMMON_FAVORITES, CSIDL_COMMON_PROGRAMS, CSIDL_COMMON_STARTMENU, CSIDL_COMMON_STARTUP, CSIDL_COMMON_TEMPLATES, CSIDL_CONTROLS, CSIDL_DESKTOP, CSIDL_DESKTOPDIRECTORY, CSIDL_DRIVES, CSIDL_PRINTERS, CSIDL_FAVORITES, CSIDL_FONTS, CSIDL_HISTORY, CSIDL_MYMUSIC, CSIDL_MYPICTURES, CSIDL_NETWORK, CSIDL_PROFILE, CSIDL_PROGRAM_FILES, CSIDL_PROGRAMS, CSIDL_RECENT, CSIDL_STARTMENU, CSIDL_STARTUP, CSIDL_TEMPLATES); var ABrowseFolder: TcxBrowseFolder; ADesktopFolder: IShellFolder; AParsedCharCount, AAttributes: Cardinal; ATempCustomPath: PWideChar; ATempPIDL: PItemIDList; begin if FIsRootChecking then Exit; ADesktopFolder := GetDesktopIShellFolder; ATempPIDL := nil; FValid := False; FShellFolder := nil; if FPidl <> nil then begin DisposePidl(FPidl); FPidl := nil; end; ABrowseFolder := BrowseFolder; if (ABrowseFolder = bfCustomPath) and (CustomPath = '') then ABrowseFolder := bfDesktop; FIsRootChecking := True; try try if ABrowseFolder = bfCustomPath then begin ATempCustomPath := StringToOleStr(CustomPath); OleCheck(ADesktopFolder.ParseDisplayName(ParentWindow, nil, ATempCustomPath, AParsedCharCount, ATempPIDL, AAttributes)); end else OleCheck(cxGetFolderLocation(ParentWindow, ACSIDLs[ABrowseFolder], 0, 0, ATempPIDL)); except on E: Exception do if FRootChangingCount > 0 then raise EcxEditError.Create(E.Message) else begin RootUpdated; Exit; end; end; if ABrowseFolder = bfDesktop then begin FShellFolder := ADesktopFolder; FPidl := GetPidlCopy(ATempPIDL); FValid := True; FAttributes := SFGAO_FILESYSTEM; RootUpdated; end else Pidl := ATempPIDL; finally FIsRootChecking := False; if ATempPIDL <> nil then DisposePidl(ATempPIDL); end; end; procedure TcxCustomShellRoot.DoSettingsChanged; begin if not FUpdating and Assigned(FOnSettingsChanged) then FOnSettingsChanged(Self); end; procedure TcxCustomShellRoot.RootUpdated; begin UpdateFolder; end; procedure TcxCustomShellRoot.SetPidl(const Value: PItemIDList); var DesktopFolder:IShellFolder; pFolder:IShellFolder; begin if Value = nil then Exit; if FPidl<>nil then begin DisposePidl(FPidl); FPidl:=nil; FValid:=False; FAttributes:=0; end; if Failed(SHGetDesktopFolder(DesktopFolder)) then Exit; if Succeeded(DesktopFolder.BindToObject(Value,nil,IID_IShellFolder, pFolder)) then begin FShellFolder:=pFolder; FPidl:=GetPidlCopy(Value); FValid:=True; FAttributes:=0; if Failed(DesktopFolder.GetAttributesOf(1,FPidl,FAttributes)) then FAttributes:=0; end else begin FShellFolder:=DesktopFolder; FPidl:=GetPidlCopy(Value); FValid:=True; FAttributes:=SFGAO_FILESYSTEM; end; RootUpdated; end; constructor TcxCustomShellRoot.Create(AOwner: TPersistent; AParentWindow: HWND); begin inherited Create; FOwner := AOwner; FParentWindow := AParentWindow; FBrowseFolder := bfDesktop; FCustomPath := ''; FShellFolder := nil; FPidl := nil; end; destructor TcxCustomShellRoot.Destroy; begin FreeAndNil(FFolder); FShellFolder := nil; DisposePidl(FPidl); inherited; end; procedure TcxCustomShellRoot.Assign(Source: TPersistent); var APrevBrowseFolder: TcxBrowseFolder; APrevCustomPath: WideString; begin if Source is TcxCustomShellRoot then begin APrevBrowseFolder := FBrowseFolder; APrevCustomPath := FCustomPath; try FBrowseFolder := TcxCustomShellRoot(Source).FBrowseFolder; FCustomPath := TcxCustomShellRoot(Source).FCustomPath; Inc(Self.FRootChangingCount); try CheckRoot; finally Dec(FRootChangingCount); end; DoSettingsChanged; except FBrowseFolder := APrevBrowseFolder; FCustomPath := APrevCustomPath; CheckRoot; raise; end; end else inherited Assign(Source); end; procedure TcxCustomShellRoot.Update(ARoot: TcxCustomShellRoot); begin if FUpdating then Exit; FUpdating := True; try Assign(ARoot); finally FUpdating := False; end; end; procedure TcxCustomShellRoot.SetBrowseFolder(Value: TcxBrowseFolder); var APrevBrowseFolder: TcxBrowseFolder; begin APrevBrowseFolder := FBrowseFolder; try Inc(FRootChangingCount); try if FBrowseFolder <> Value then begin FBrowseFolder := Value; CheckRoot; end else if Pidl = nil then CheckRoot; finally Dec(FRootChangingCount); end; DoSettingsChanged; except FBrowseFolder := APrevBrowseFolder; CheckRoot; raise; end; end; procedure TcxCustomShellRoot.SetCustomPath(const Value: WideString); var APrevCustomPath: WideString; begin APrevCustomPath := FCustomPath; try FCustomPath := Value; Inc(FRootChangingCount); try if BrowseFolder = bfCustomPath then CheckRoot; finally Dec(FRootChangingCount); end; DoSettingsChanged; except FCustomPath := APrevCustomPath; CheckRoot; raise; end; end; function TcxCustomShellRoot.GetCurrentPath: WideString; var Desktop:IShellFolder; StrName:TStrRet; begin Result:=''; if Pidl<>nil then begin if Failed(SHGetDesktopFolder(Desktop)) then Exit; if Succeeded(Desktop.GetDisplayNameOf(Pidl,SHGDN_NORMAL or SHGDN_FORPARSING,StrName)) then Result:=GetTextFromStrRet(StrName,Pidl); end; end; procedure TcxCustomShellRoot.UpdateFolder; begin FreeAndNil(FFolder); FFolder := TcxShellFolder.Create(PIDL); end; { TcxCustomItemProducer } procedure TcxCustomItemProducer.ClearItems; (*function HasItems: Boolean; begin LockRead; try Result := Items.Count <> 0; finally UnlockRead; end; end;*) var I: Integer; begin //if HasItems then begin ClearFetchQueue; for I := 0 to Items.Count - 1 do TcxShellItemInfo(Items[I]).Free; Items.Clear; end; FShellFolder := nil; if FFolderPidl <> nil then begin DisposePidl(FFolderPidl); FFolderPidl := nil; end; end; constructor TcxCustomItemProducer.Create(AOwner: TWinControl); begin inherited Create; FOwner := AOwner; FDetails := TcxShellDetails.Create; FItems := TList.Create; FItemsLock := TMultiReadExclusiveWriteSynchronizer.Create; end; procedure TcxCustomItemProducer.RequestItemsInfo; var I: Integer; begin ItemsInfoGatherer.StopFetch; try for I := 0 to Items.Count - 1 do if not TcxShellItemInfo(Items[I]).Updated then FetchRequest(I, False); finally ItemsInfoGatherer.ResumeFetch; end; end; destructor TcxCustomItemProducer.Destroy; begin ClearItems; FreeAndNil(FDetails); FreeAndNil(FItems); FreeAndNil(FItemsLock); inherited Destroy; end; procedure TcxCustomItemProducer.LockRead; begin ItemsLock.BeginRead; end; procedure TcxCustomItemProducer.LockWrite; begin ItemsLock.BeginWrite; end; procedure TcxCustomItemProducer.ProcessItems(AIFolder: IShellFolder; AFolderPIDL: PItemIDList; cPreloadItems: Integer); begin if FFolderPidl <> nil then begin DisposePidl(FFolderPidl); FFolderPidl := nil; end; FShellFolder := AIFolder; FFolderPidl := GetPidlCopy(AFolderPIDL); ProcessDetails(ShellFolder, cPreloadItems); FetchItems(cPreloadItems); if AllowBackgroundProcessing then RequestItemsInfo; end; procedure TcxCustomItemProducer.SetItemsCount(Count: Integer); begin if Owner.HandleAllocated then SendMessage(Owner.Handle, DSM_SETCOUNT, Count, 0); end; procedure TcxCustomItemProducer.UnlockRead; begin ItemsLock.EndRead; end; procedure TcxCustomItemProducer.UnlockWrite; begin ItemsLock.EndWrite; end; procedure TcxCustomItemProducer.NotifyRemoveItem(Index: Integer); begin if Owner.HandleAllocated then SendMessage(Owner.Handle, DSM_NOTIFYREMOVEITEM, Index, 0); end; procedure TcxCustomItemProducer.NotifyAddItem(Index: Integer); begin if Owner.HandleAllocated then SendMessage(Owner.Handle, DSM_NOTIFYADDITEM, Index, 0); end; procedure TcxCustomItemProducer.InitializeItem(Item:TcxShellItemInfo); begin // Do nothing by default end; function TcxCustomItemProducer.CanAddFolder(AFolder: TcxShellFolder): Boolean; begin Result := True; end; function TcxCustomItemProducer.DoCompareItems(AItem1, AItem2: TcxShellFolder; out ACompare: Integer): Boolean; begin Result := False; end; procedure TcxCustomItemProducer.DoSort; function ShellSortFunction(Item1, Item2: Pointer): Integer; const R: array[Boolean] of Byte = (0, 1); var AItemInfo1, AItemInfo2: TcxShellItemInfo; begin AItemInfo1 := TcxShellItemInfo(Item1); AItemInfo2 := TcxShellItemInfo(Item2); if not AItemInfo1.ItemProducer.DoCompareItems(AItemInfo1.Folder, AItemInfo2.Folder, Result) then begin Result := R[AItemInfo2.IsFolder] - R[AItemInfo1.IsFolder]; if Result = 0 then Result := SmallInt(AItemInfo1.ItemProducer.ShellFolder.CompareIDs(0, AItemInfo1.pidl, AItemInfo2.pidl)); end; end; begin Items.Sort(@ShellSortFunction); end; procedure TcxCustomItemProducer.FetchItems(APreloadItems: Integer); var pEnum: IEnumIDList; ACurrentCelt: Cardinal; APidl: PItemIDList; AItem: TcxShellItemInfo; AHResult: HRESULT; AIsEnumElementValid: Boolean; begin if Succeeded(ShellFolder.EnumObjects(Owner.ParentWindow, GetEnumFlags, pEnum)) and Assigned(pEnum) then begin ACurrentCelt := 1; ShowHourglassCursor; try LockWrite; try repeat AHResult := pEnum.Next(ACurrentCelt, APidl, ACurrentCelt); if AHResult = E_INVALIDARG then begin ACurrentCelt := 1; AHResult := pEnum.Next(ACurrentCelt, APidl, ACurrentCelt); end; AIsEnumElementValid := Succeeded(AHResult) and (AHResult <> S_FALSE) and (ACurrentCelt <> 0) and (APidl <> nil); if AIsEnumElementValid then try AItem := TcxShellItemInfo.Create(Self, ShellFolder, FFolderPidl, APidl, False); if (AItem.Name = '') or not CanAddFolder(AItem.Folder) then AItem.Free else begin if APreloadItems > 0 then begin AItem.CheckUpdate(ShellFolder, FolderPidl, False); Dec(APreloadItems); end else InitializeItem(AItem); Items.Add(AItem); end; finally DisposePidl(APidl); end; until not AIsEnumElementValid; Sort; finally UnlockWrite; end; SetItemsCount(Items.Count); finally HideHourglassCursor; end; end; end; procedure TcxCustomItemProducer.ProcessDetails(ShellFolder: IShellFolder; CharWidth: Integer); var DesktopFolder:IShellFolder; Attr:Cardinal; tempPidl:PitemIDList; begin if Failed(SHGetDesktopFolder(DesktopFolder)) then Exit; Attr:=0; tempPidl:=GetPidlCopy(FolderPidl); try if Failed(DesktopFolder.GetAttributesOf(1,tempPidl,Attr)) then Attr:=0; Details.ProcessDetails(CharWidth,ShellFolder,(Attr and SFGAO_FILESYSTEM)=SFGAO_FILESYSTEM); finally DisposePidl(tempPidl); end; end; procedure TcxCustomItemProducer.DoGetInfoTip(Handle:HWND;ItemIndex: Integer; InfoTip: PChar; cch: Integer); var ATempShellItem: TcxShellItemInfo; ATempPidl: PItemIDList; AQueryInfo: IQueryInfo; AInfoStr: PWideChar; {$IFNDEF DELPHI12}ADefaultChar: Char;{$ENDIF} begin if GetShowToolTip then begin if ItemIndex > Items.Count - 1 then Exit; ATempShellItem := Items[ItemIndex]; ATempPidl := GetPidlCopy(ATempShellItem.pidl); try if Succeeded(ShellFolder.GetUIObjectOf(Handle, 1, ATempPidl, IQueryInfo, nil, AQueryInfo)) and Succeeded(AQueryInfo.GetInfoTip(0, AInfoStr)) and (AInfoStr <> nil) then begin {$IFDEF DELPHI12} StrLCopy(InfoTip, AInfoStr, cch); {$ELSE} ADefaultChar := #$7F; cch := WideCharToMultiByte(0, 0, AInfoStr, -1, nil, 0, @ADefaultChar, nil); WideCharToMultiByte(0, 0, AInfoStr, -1, InfoTip, cch, @ADefaultChar, nil); StrPLCopy(InfoTip, StringReplace(InfoTip, ADefaultChar, '', [rfReplaceAll]), cch); {$ENDIF} cxMalloc.Free(AInfoStr); end; finally DisposePidl(ATempPidl); end; end else StrPLCopy(InfoTip, '', cch); end; function TcxCustomItemProducer.GetItemByPidl( APidl: PItemIDList): TcxShellItemInfo; var AItemIndex: Integer; begin AItemIndex := GetItemIndexByPidl(APidl); if AItemIndex <> -1 then Result := Items[AItemIndex] else Result := nil; end; function TcxCustomItemProducer.GetItemIndexByPidl( APidl: PItemIDList): Integer; var I: Integer; AItem: TcxShellItemInfo; begin Result := -1; LockRead; try for I := 0 to Items.Count - 1 do begin AItem := Items[I]; if SmallInt(ShellFolder.CompareIDs(0, AItem.pidl, APidl)) = 0 then begin Result := I; Break; end; end; finally UnlockRead; end; end; procedure TcxCustomItemProducer.Sort; begin LockWrite; try DoSort; finally UnlockWrite; end; end; procedure TcxCustomItemProducer.FetchRequest(AIndex: Integer; APriority: Boolean = False); begin ItemsInfoGatherer.RequestItemInfo(Self, AIndex, APriority); end; procedure TcxCustomItemProducer.ClearFetchQueue; begin ItemsInfoGatherer.ClearFetchQueue(Self); end; procedure TcxCustomItemProducer.CheckForSubitems(AItem: TcxShellItemInfo); begin end; { TcxShellItemsInfoGatherer } constructor TcxShellItemsInfoGatherer.Create(AOwner: TWinControl); begin inherited Create; FOwner := AOwner; FFetchQueue := TList.Create; CreateFetchThread; RegisterShellItemsInfoGatherer(Self); end; destructor TcxShellItemsInfoGatherer.Destroy; begin UnregisterShellItemsInfoGatherer(Self); DestroyFetchThread; FreeAndNil(FFetchQueue); inherited Destroy; end; procedure TcxShellItemsInfoGatherer.ClearFetchQueue( AItemProducer: TcxCustomItemProducer); procedure InternalClearFetchQueue; var AItem: PcxRequestItem; I: Integer; begin I := 0; while I < FetchQueue.Count do begin AItem := FetchQueue[I]; if (AItemProducer = nil) or (AItem.ItemProducer = AItemProducer) then begin FetchQueue.Remove(AItem); Dispose(AItem); end else Inc(I); end; end; begin if FIsFetchQueueClearing then Exit; FIsFetchQueueClearing := True; StopFetch; try InternalClearFetchQueue; finally FIsFetchQueueClearing := False; ResumeFetch; end; end; procedure TcxShellItemsInfoGatherer.RequestItemInfo( AItemProducer: TcxCustomItemProducer; AIndex: Integer; APriority: Boolean); var AItemIndex: Integer; begin StopFetch; try AItemIndex := GetFetchQueueItemIndex(FetchQueue, AItemProducer, AIndex); if AItemIndex = -1 then begin if APriority then FetchQueue.Insert(0, CreateRequestItem(AItemProducer, AIndex, True)) else FetchQueue.Add(CreateRequestItem(AItemProducer, AIndex, False)); end else if APriority then FetchQueue.Move(AItemIndex, 0); finally ResumeFetch; end; end; procedure TcxShellItemsInfoGatherer.ResumeFetch; begin if FStopFetchCount > 0 then begin Dec(FStopFetchCount); if FStopFetchCount = 0 then ResetEvent(FStopFetchEvent); end; end; procedure TcxShellItemsInfoGatherer.StopFetch; begin Inc(FStopFetchCount); if FStopFetchCount = 1 then begin SetEvent(FStopFetchEvent); WaitForSingleObject(FFetchStoppedEvent, INFINITE); end; end; procedure TcxShellItemsInfoGatherer.DestroyFetchThread; begin TerminateFetchThread; InternalCloseHandle(FFetchThread); InternalCloseHandle(FFetchStoppedEvent); InternalCloseHandle(FStopFetchEvent); InternalCloseHandle(FTerminateFetchThreadEvent); end; procedure TcxShellItemsInfoGatherer.CreateFetchThread; var AFetchThreadID: DWORD; begin FFetchStoppedEvent := CreateEvent(nil, True, False, nil); FStopFetchEvent := CreateEvent(nil, True, False, nil); FTerminateFetchThreadEvent := CreateEvent(nil, True, False, nil); FFetchThread := CreateThread(nil, 0, @cxShellItemsInfoGathererFetchThreadFunction, Self, 0, AFetchThreadID); end; function TcxShellItemsInfoGatherer.CreateRequestItem( AItemProducer: TcxCustomItemProducer; AIndex: Integer; APriority: Boolean): PcxRequestItem; begin New(Result); Result.ItemIndex := AIndex; Result.ItemProducer := AItemProducer; Result.Priority := APriority; end; function TcxShellItemsInfoGatherer.GetFetchQueueItemIndex( AFetchQueue: TList; AItemProducer: TcxCustomItemProducer; AIndex: Integer): Integer; var APItem: PcxRequestItem; I: Integer; begin Result := -1; for I := 0 to AFetchQueue.Count - 1 do begin APItem := AFetchQueue[I]; if (APItem.ItemIndex = AIndex) and (APItem.ItemProducer = AItemProducer) then begin Result := I; Break; end; end; end; function TcxShellItemsInfoGatherer.GetIsFetchStopping: Boolean; begin Result := WaitForSingleObject(FStopFetchEvent, 0) = WAIT_OBJECT_0; end; function TcxShellItemsInfoGatherer.GetIsFetchThreadTerminating: Boolean; begin Result := WaitForSingleObject(FTerminateFetchThreadEvent, 0) = WAIT_OBJECT_0; end; procedure TcxShellItemsInfoGatherer.FetchResumed; begin ResetEvent(FFetchStoppedEvent); end; procedure TcxShellItemsInfoGatherer.FetchStopped; begin SetEvent(FFetchStoppedEvent); end; procedure TcxShellItemsInfoGatherer.InternalCloseHandle(var AHandle: THandle); begin CloseHandle(AHandle); AHandle := 0; end; procedure TcxShellItemsInfoGatherer.TerminateFetchThread; begin SetEvent(FTerminateFetchThreadEvent); WaitForSingleObject(FFetchThread, INFINITE); end; { TcxShellFolder } constructor TcxShellFolder.Create(AAbsolutePIDL: PItemIDList); var AParentPIDL: PItemIDList; begin inherited Create; FAbsolutePIDL := AAbsolutePIDL; if GetPIDLItemsCount(FAbsolutePIDL) <= 1 then begin FParentShellFolder := GetDesktopIShellFolder; FRelativePIDL := GetPIDLCopy(FAbsolutePIDL); end else begin AParentPIDL := GetPIDLParent(FAbsolutePIDL); try GetDesktopIShellFolder.BindToObject(AParentPIDL, nil, IID_IShellFolder, FParentShellFolder); finally DisposePidl(AParentPIDL); end; FRelativePIDL := GetPIDLCopy(GetLastPIDLItem(FAbsolutePIDL)); end; end; destructor TcxShellFolder.Destroy; begin DisposePIDL(FRelativePIDL); inherited Destroy; end; function TcxShellFolder.GetAttributes: TcxShellFolderAttributes; procedure CheckAttribute(AShellAttributes, AAttributeShellAttribute: LongWord; AAttribute: TcxShellFolderAttribute); begin if HasShellAttribute(AShellAttributes, AAttributeShellAttribute) then Include(Result, AAttribute); end; var AShellAttributes: LongWord; begin AShellAttributes := GetShellAttributes(SFGAO_DISPLAYATTRMASK); Result := []; CheckAttribute(AShellAttributes, cxSFGAO_GHOSTED, sfaGhosted); CheckAttribute(AShellAttributes, SFGAO_HIDDEN, sfaHidden); CheckAttribute(AShellAttributes, SFGAO_ISSLOW, sfaIsSlow); CheckAttribute(AShellAttributes, SFGAO_LINK, sfaLink); CheckAttribute(AShellAttributes, SFGAO_READONLY, sfaReadOnly); CheckAttribute(AShellAttributes, SFGAO_SHARE, sfaShare); end; function TcxShellFolder.GetCapabilities: TcxShellFolderCapabilities; procedure CheckCapability(AShellAttributes, ACapabilityShellAttribute: LongWord; ACapability: TcxShellFolderCapability); begin if HasShellAttribute(AShellAttributes, ACapabilityShellAttribute) then Include(Result, ACapability); end; var AShellAttributes: LongWord; begin AShellAttributes := GetShellAttributes(SFGAO_CAPABILITYMASK); Result := []; CheckCapability(AShellAttributes, SFGAO_CANCOPY, sfcCanCopy); CheckCapability(AShellAttributes, SFGAO_CANDELETE, sfcCanDelete); CheckCapability(AShellAttributes, SFGAO_CANLINK, sfcCanLink); CheckCapability(AShellAttributes, SFGAO_CANMOVE, sfcCanMove); CheckCapability(AShellAttributes, SFGAO_CANRENAME, sfcCanRename); CheckCapability(AShellAttributes, SFGAO_DROPTARGET, sfcDropTarget); CheckCapability(AShellAttributes, SFGAO_HASPROPSHEET, sfcHasPropSheet); end; function TcxShellFolder.GetDisplayName: string; begin Result := InternalGetDisplayName(ParentShellFolder, RelativePIDL, SHGDN_INFOLDER); end; function TcxShellFolder.GetIsFolder: Boolean; begin Result := HasShellAttribute(SFGAO_FOLDER); end; function TcxShellFolder.GetPathName: string; function GetDisplayName(ANameType: DWORD): string; begin Result := InternalGetDisplayName(GetDesktopIShellFolder, AbsolutePIDL, ANameType); end; begin Result := InternalGetDisplayName(GetDesktopIShellFolder, AbsolutePIDL, SHGDN_FORPARSING); if Pos('::{', Result) = 1 then Result := InternalGetDisplayName(GetDesktopIShellFolder, AbsolutePIDL, SHGDN_NORMAL); end; function TcxShellFolder.GetProperties: TcxShellFolderProperties; procedure CheckProperty(AShellAttributes, APropertyShellAttribute: LongWord; AProperty: TcxShellFolderProperty); begin if HasShellAttribute(AShellAttributes, APropertyShellAttribute) then Include(Result, AProperty); end; var AShellAttributes: LongWord; begin AShellAttributes := GetShellAttributes(SFGAO_BROWSABLE or SFGAO_COMPRESSED or SFGAO_ENCRYPTED or SFGAO_NEWCONTENT or SFGAO_NONENUMERATED or SFGAO_REMOVABLE); Result := []; CheckProperty(AShellAttributes, SFGAO_BROWSABLE, sfpBrowsable); CheckProperty(AShellAttributes, SFGAO_COMPRESSED, sfpCompressed); CheckProperty(AShellAttributes, SFGAO_ENCRYPTED, sfpEncrypted); CheckProperty(AShellAttributes, SFGAO_NEWCONTENT, sfpNewContent); CheckProperty(AShellAttributes, SFGAO_NONENUMERATED, sfpNonEnumerated); CheckProperty(AShellAttributes, SFGAO_REMOVABLE, sfpRemovable); end; function TcxShellFolder.GetShellAttributes(ARequestedAttributes: LongWord): LongWord; begin ParentShellFolder.GetAttributesOf(1, FRelativePIDL, ARequestedAttributes); Result := ARequestedAttributes; end; function TcxShellFolder.GetShellFolder: IShellFolder; begin if GetPIDLItemsCount(AbsolutePIDL) = 0 then Result := GetDesktopIShellFolder else GetDesktopIShellFolder.BindToObject(AbsolutePIDL, nil, IID_IShellFolder, Result); end; function TcxShellFolder.GetStorageCapabilities: TcxShellFolderStorageCapabilities; procedure CheckStorageCapability(AShellAttributes, AStorageCapabilityShellAttribute: LongWord; AStorageCapability: TcxShellFolderStorageCapability); begin if HasShellAttribute(AShellAttributes, AStorageCapabilityShellAttribute) then Include(Result, AStorageCapability); end; var AShellAttributes: LongWord; begin AShellAttributes := GetShellAttributes(SFGAO_STORAGECAPMASK); Result := []; CheckStorageCapability(AShellAttributes, SFGAO_FILESYSANCESTOR, sfscFileSysAncestor); CheckStorageCapability(AShellAttributes, SFGAO_FILESYSTEM, sfscFileSystem); CheckStorageCapability(AShellAttributes, SFGAO_FOLDER, sfscFolder); CheckStorageCapability(AShellAttributes, SFGAO_LINK, sfscLink); CheckStorageCapability(AShellAttributes, SFGAO_READONLY, sfscReadOnly); CheckStorageCapability(AShellAttributes, SFGAO_STORAGE, sfscStorage); CheckStorageCapability(AShellAttributes, SFGAO_STORAGEANCESTOR, sfscStorageAncestor); CheckStorageCapability(AShellAttributes, SFGAO_STREAM, sfscStream); end; function TcxShellFolder.GetSubFolders: Boolean; begin Result := HasShellAttribute(SFGAO_HASSUBFOLDER); end; function TcxShellFolder.HasShellAttribute(AAttribute: LongWord): Boolean; begin Result := HasShellAttribute(GetShellAttributes(AAttribute), AAttribute); end; function TcxShellFolder.HasShellAttribute(AAttributes, AAttribute: LongWord): Boolean; begin Result := AAttributes and AAttribute <> 0; end; function TcxShellFolder.InternalGetDisplayName(AFolder: IShellFolder; APIDL: PItemIDList; ANameType: DWORD): string; var AStrRet: TStrRet; begin AFolder.GetDisplayNameOf(APIDL, ANameType, AStrRet); Result := GetTextFromStrRet(AStrRet, APIDL); end; { TcxShellItemInfo } procedure TcxShellItemInfo.CheckInitialize(AIFolder: IShellFolder; APIDL: PItemIDList); var AAttributes: Cardinal; begin if Initialized then Exit; AAttributes := SFGAO_FOLDER; if Succeeded(AIFolder.GetAttributesOf(1, APIDL, AAttributes)) then FIsFolder := AAttributes and SFGAO_FOLDER <> 0 else begin FIsFolder := False; FIsFilesystem := False; FIsDropTarget := True; FCanRename := True; end; if IsFolder then FHasSubfolder := True else FHasSubfolder := False; FName := GetShellItemDisplayName(AIFolder, APIDL, IsFolder); if IsFolder then begin FIconIndex := sysFolderIconIndex; FOpenIconIndex := sysFolderOpenIconIndex; end else begin FIconIndex := sysFileIconIndex; FOpenIconIndex := sysFileIconIndex; end; FInitialized := True; end; { TcxShellItemInfo } procedure TcxShellItemInfo.CheckSubitems(AParentIFolder: IShellFolder; AEnumSettings: Cardinal); begin FHasSubfolder := HasSubItems(AParentIFolder, FFullPIDL, AEnumSettings); end; procedure TcxShellItemInfo.CheckUpdate(ShellFolder: IShellFolder; FolderPidl:PItemIDList;Fast:Boolean); var attr:Cardinal; FileInfo:TShFileInfo; fqPidl:PItemIDList; Flags:Cardinal; pszName:PChar; tempPidl:PItemIDList; begin if Updated or Updating then Exit; Updating:=True; try Assert(pidl<>nil,'Item object not initialized'); if pidl=nil then Exit; fqPidl:=ConcatenatePidls(FolderPidl,pidl); try attr:=0; tempPidl:=pidl; CheckInitialize(ShellFolder,tempPidl); if Fast then begin if not IsFolder then begin GetMem(pszName,MAX_PATH); try StrPLCopy(pszName,Name,MAX_PATH); cxShellGetThreadSafeFileInfo(pszName,FILE_ATTRIBUTE_NORMAL,FileInfo,SizeOf(TShFileInfo), SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES); FIconIndex:=FileInfo.iIcon; cxShellGetThreadSafeFileInfo(pszName,FILE_ATTRIBUTE_NORMAL,FileInfo,SizeOf(TShFileInfo), SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES or SHGFI_OPENICON); FOpenIconIndex:=FileInfo.iIcon; finally FreeMem(pszName); end; end else begin Flags:=SHGFI_PIDL or SHGFI_SYSICONINDEX; cxShellGetThreadSafeFileInfo(PChar(fqPidl),0,FileInfo,SizeOf(FileInfo),Flags); FIconIndex:=FileInfo.iIcon; end; end else begin // Processing attributes if Succeeded(ShellFolder.GetAttributesOf(1,TempPidl,attr)) then FIsFilesystem:=(attr and SFGAO_FILESYSTEM)=SFGAO_FILESYSTEM; attr:=SFGAO_HIDDEN or SFGAO_SHARE or SFGAO_LINK or SFGAO_REMOVABLE; if Succeeded(ShellFolder.GetAttributesOf(1,TempPidl,attr)) then begin FIsGhosted:=(attr and SFGAO_HIDDEN)=SFGAO_HIDDEN; FIsShare:=(attr and SFGAO_SHARE)=SFGAO_SHARE; FIsLink:=(attr and SFGAO_LINK)=SFGAO_LINK; FIsRemovable:=(attr and SFGAO_REMOVABLE)=SFGAO_REMOVABLE; end; attr:=SFGAO_CAPABILITYMASK; if Succeeded(ShellFolder.GetAttributesOf(1,TempPidl,attr)) then begin FIsDropTarget:=(attr and SFGAO_DROPTARGET)=SFGAO_DROPTARGET; FCanRename:=(attr and SFGAO_CANRENAME)=SFGAO_CANRENAME; end; // Processing icons Flags:=SHGFI_PIDL or SHGFI_SYSICONINDEX or SHGFI_TYPENAME; cxShellGetThreadSafeFileInfo(PChar(fqPidl),0,FileInfo,SizeOf(FileInfo),Flags); FIconIndex:=FileInfo.iIcon; if FIsFolder then cxShellGetThreadSafeFileInfo(PChar(fqPidl),0,FileInfo,SizeOf(FileInfo),Flags or SHGFI_OPENICON); FOpenIconIndex:=FileInfo.iIcon; Updated:=True; end; finally DisposePidl(fqPidl); end; finally Updating:=False; end; end; constructor TcxShellItemInfo.Create(AItemProducer: TcxCustomItemProducer; AParentIFolder: IShellFolder; AParentPIDL, APIDL: PItemIDList; AFast: Boolean); var AWithoutAV: Boolean; begin inherited Create; FItemProducer := AItemProducer; // the following code required to get rid of bug, that occasionally appeared // on Windows XP. The pidl received from thr shell, anothed memory block // allocated internally, but occasionally appeared exception thad CopyMemory // can't be performed FDetails := TStringList.Create; repeat try FPIDL := GetPidlCopy(APIDL); AWithoutAV := True; except AWithoutAV := False; end; until AWithoutAV; if not AFast then CheckInitialize(AParentIFolder, APIDL) else begin FName := ' '; FIconIndex := sysFileIconIndex; FOpenIconIndex := sysFileIconIndex; end; FInfoTip := ''; FUpdated := False; FUpdating := False; FFullPIDL := ConcatenatePidls(AParentPIDL, APIDL); FFolder := TcxShellFolder.Create(FFullPIDL); end; destructor TcxShellItemInfo.Destroy; begin FreeAndNil(FFolder); DisposePidl(FFullPIDL); DisposePidl(Fpidl); FreeAndNil(FDetails); inherited; end; procedure TcxShellItemInfo.FetchDetails(wnd:HWND;ShellFolder: IShellFolder;DetailsMap:TcxShellDetails); function FormatSizeStr(AStr: string): string; begin Result := FormatMaskText('!### ### ### KB;0;*', AStr); end; function GetFileTypeInfo(const AFilename: string): string; begin Result := GetRegStringValue(GetRegStringValue(ExtractFileExt(AFileName), ''), ''); end; var AColumnDetails: TShellDetails; AFileInfo: TWIN32FindData; AFileSize: record case integer of 0:(l,h:cardinal); 1:(c:int64); end; AFindFileHandle: THandle; APDetailItem: PcxDetailItem; AShellDetails: IShellDetails; AShellFolder2: IShellFolder2; AStrPath: TStrRet; ATempName: PChar; I: Integer; begin // Processing details Details.Clear; if Succeeded(ShellFolder.QueryInterface({$IFNDEF DELPHI6}cxIID_IShellFolder2{$ELSE}cxIShellFolder2{$ENDIF}, AShellFolder2)) then begin for I := 0 to DetailsMap.Count - 1 do begin APDetailItem := DetailsMap[I]; if APDetailItem.ID = 0 then Continue; // Name column already exists if AShellFolder2.GetDetailsOf(pidl, APDetailItem.ID, AColumnDetails) = S_OK then Details.Add(GetTextFromStrRet(AColumnDetails.str, pidl)) else Details.Add(''); end; end else if Succeeded(GetShellDetails(ShellFolder, pidl, AShellDetails)) then begin for I := 0 to DetailsMap.Count - 1 do begin APDetailItem := DetailsMap[I]; if APDetailItem.ID = 0 then Continue; // Name column already exists if AShellDetails.GetDetailsOf(pidl, APDetailItem.ID, AColumnDetails) = S_OK then Details.Add(GetTextFromStrRet(AColumnDetails.str, pidl)) else Details.Add(''); end; end else if IsFilesystem then begin if Failed(ShellFolder.GetDisplayNameOf(pidl, SHGDN_NORMAL or SHGDN_FORPARSING, AStrPath)) then Exit; GetMem(ATempName, MAX_PATH); try StrPLCopy(ATempName, GetTextFromStrRet(AStrPath, pidl), MAX_PATH); AFindFileHandle := FindFirstFile(ATempName, AFileInfo); if AFindFileHandle <> INVALID_HANDLE_VALUE then try AFileSize.h := AFileInfo.nFileSizeHigh; AFileSize.l := AFileInfo.nFileSizeLow; Details.Add(FormatSizeStr(IntToStr(Ceil(AFileSize.c/1024)))); Details.Add(GetFileTypeInfo(AFileInfo.cFileName)); Details.Add(DateTimeToStr(cxFileTimeToDateTime(AFileInfo.ftLastWriteTime))); finally Windows.FindClose(AFindFileHandle); end; finally FreeMem(ATempName); end; end; end; procedure TcxShellItemInfo.SetNewPidl(pFolder:IShellFolder;FolderPidl,apidl: PItemIDList); begin if apidl=nil then Exit; if Fpidl<>nil then DisposePidl(FPidl); FPidl:=GetPidlCopy(apidl); Updated:=False; CheckUpdate(pFolder,FolderPidl,False); end; { TcxShellOptions } constructor TcxShellOptions.Create(AOwner: TWinControl); begin inherited Create; FOwner := AOwner; FContextMenus := True; FShowFolders := True; FShowNonFolders := True; FShowToolTip := True; FTrackShellChanges := True; end; procedure TcxShellOptions.Assign(Source: TPersistent); begin if Source is TcxShellOptions then with TcxShellOptions(Source) do begin Self.FContextMenus := FContextMenus; Self.FShowFolders := FShowFolders; Self.FShowHidden := FShowHidden; Self.FShowNonFolders := FShowNonFolders; Self.ShowToolTip := ShowToolTip; Self.FTrackShellChanges := FTrackShellChanges; NotifyUpdateContents; end else inherited Assign(Source); end; function TcxShellOptions.GetEnumFlags: Cardinal; begin if ShowFolders then Result := SHCONTF_FOLDERS else Result := 0; if ShowNonFolders then Result := Result or SHCONTF_NONFOLDERS; if ShowHidden then Result := Result or SHCONTF_INCLUDEHIDDEN; end; procedure TcxShellOptions.NotifyUpdateContents; begin if Owner.HandleAllocated then SendMessage(Owner.Handle, DSM_NOTIFYUPDATECONTENTS, 0, 0); end; procedure TcxShellOptions.SetShowFolders(Value: Boolean); begin FShowFolders := Value; NotifyUpdateContents; end; procedure TcxShellOptions.SetShowHidden(Value: Boolean); begin FShowHidden := Value; NotifyUpdateContents; end; procedure TcxShellOptions.SetShowNonFolders(Value: Boolean); begin FShowNonFolders := Value; NotifyUpdateContents; end; procedure TcxShellOptions.SetShowToolTip(Value: Boolean); begin if Value <> FShowToolTip then begin FShowToolTip := Value; if Assigned(FOnShowToolTipChanged) then FOnShowToolTipChanged(Self); end; end; { TcxShellDetails } function TcxShellDetails.Add: PcxDetailItem; begin New(Result); Items.Add(Result); end; procedure TcxShellDetails.Clear; var di:PcxDetailItem; begin while Items.Count<>0 do begin di:=Items.Last; Items.Remove(di); Dispose(di); end; end; constructor TcxShellDetails.Create; begin inherited Create; FItems:=TList.Create; end; destructor TcxShellDetails.Destroy; begin Clear; FreeAndNil(FItems); end; function TcxShellDetails.GetCount: Integer; begin Result:=Items.Count; end; function TcxShellDetails.GetItems(Index: Integer): PcxDetailItem; begin Result:=Items[Index]; end; procedure TcxShellDetails.ProcessDetails(ACharWidth: Integer; AShellFolder: IShellFolder; AFileSystem: Boolean); const AAlignment: array[0..2] of TAlignment = (taLeftJustify, taRightJustify, taCenter); var AColumnDetails: TShellDetails; AColumnFlags: Cardinal; AColumnIndex: Integer; SD: IShellDetails; SF2: IShellFolder2; procedure SetItemInfo(AItem: PcxDetailItem; AText: string; AWidth:Integer; AAlignment: TAlignment; AID:Integer); begin AItem.Text := AText; AItem.Width := AWidth * ACharWidth; AItem.Alignment := AAlignment; AItem.ID := AID; end; procedure AddItem(ADetails: TShellDetails; AIndex: Integer; AText: string); var ANewColumn: PcxDetailItem; begin ANewColumn := Add; SetItemInfo(ANewColumn, AText, ADetails.cxChar, AAlignment[ADetails.fmt], AIndex); end; var ADefaultColumns: Boolean; AText: WideString; begin ZeroMemory(@AColumnDetails, SizeOf(AColumnDetails)); AColumnIndex := 0; Clear; if Succeeded(AShellFolder.QueryInterface({$IFNDEF DELPHI6}cxIID_IShellFolder2{$ELSE}cxIShellFolder2{$ENDIF}, SF2)) then begin ADefaultColumns := False; while SF2.GetDetailsOf(nil, AColumnIndex, AColumnDetails) = S_OK do begin Inc(AColumnIndex); AText := GetTextFromStrRet(AColumnDetails.str, nil); if Succeeded(SF2.GetDefaultColumnState(AColumnIndex - 1, AColumnFlags)) then begin ADefaultColumns := ADefaultColumns or (AColumnFlags and SHCOLSTATE_ONBYDEFAULT = SHCOLSTATE_ONBYDEFAULT); if not IsWinXPOrLater and ADefaultColumns and (AColumnFlags and SHCOLSTATE_ONBYDEFAULT <> SHCOLSTATE_ONBYDEFAULT) then Break; if (AColumnFlags and SHCOLSTATE_ONBYDEFAULT <> SHCOLSTATE_ONBYDEFAULT) or (AColumnFlags and SHCOLSTATE_HIDDEN = SHCOLSTATE_HIDDEN) then Continue; end; AddItem(AColumnDetails, AColumnIndex - 1, AText); end; end else if GetShellDetails(AShellFolder, nil, SD) = S_OK then begin while SD.GetDetailsOf(nil, AColumnIndex, AColumnDetails) = S_OK do begin AText := GetTextFromStrRet(AColumnDetails.str, nil); AddItem(AColumnDetails, AColumnIndex, AText); Inc(AColumnIndex); end; end else begin // Processing creating columns manually (for Win95/98) SetItemInfo(Add, SShellDefaultNameStr, 25, taLeftJustify, 0); if AFileSystem then begin SetItemInfo(Add, SShellDefaultSizeStr, 10, taRightJustify, 1); SetItemInfo(Add, SShellDefaultTypeStr, 10, taLeftJustify, 2); SetItemInfo(Add, SShellDefaultModifiedStr, 14, taLeftJustify, 3); end; end; end; procedure TcxShellDetails.Remove(Item: PcxDetailItem); begin Items.Remove(Item); Dispose(Item); end; { TcxDropTarget } constructor TcxDropSource.Create(AOwner: TWinControl); begin inherited Create; FOwner := AOwner; end; function TcxDropSource.GiveFeedback(dwEffect: Integer): HResult; begin Result:=DRAGDROP_S_USEDEFAULTCURSORS; end; function TcxDropSource.QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Integer): HResult; begin if fEscapePressed then Result:=DRAGDROP_S_CANCEL else if ((grfKeyState and MK_LBUTTON)<>MK_LBUTTON) and ((grfKeyState and MK_RBUTTON)<>MK_RBUTTON) then Result:=DRAGDROP_S_DROP else Result:=S_OK; end; { TcxDragDropSettings } constructor TcxDragDropSettings.Create; begin inherited Create; FAllowDragObjects := True; FDefaultDropEffect := deMove; FDropEffect := [deMove, deCopy, deLink]; end; procedure TcxDragDropSettings.Changed; begin if Assigned(FOnChange) then FOnChange(Self); end; function TcxDragDropSettings.GetDefaultDropEffectAPI: Integer; begin case DefaultDropEffect of deCopy: Result := DROPEFFECT_COPY; deMove: Result := DROPEFFECT_MOVE; deLink: Result := DROPEFFECT_LINK; else Result := DROPEFFECT_NONE; end; end; function TcxDragDropSettings.GetDropEffectAPI: DWORD; begin Result := 0; if deCopy in DropEffect then Result := Result or DROPEFFECT_COPY; if deMove in DropEffect then Result := Result or DROPEFFECT_MOVE; if deLink in DropEffect then Result := Result or DROPEFFECT_LINK; end; procedure TcxDragDropSettings.SetAllowDragObjects(Value: Boolean); begin if Value <> FAllowDragObjects then begin FAllowDragObjects := Value; Changed; end; end; procedure cxShellInitialize; begin FComInitializationSucceeded := Succeeded(OleInitialize(nil)); FShellLock := TCriticalSection.Create; ShellLibrary := LoadLibrary(ShellLibraryName); cxSHGetFolderLocation := GetProcAddress(ShellLibrary, 'SHGetFolderLocation'); SHChangeNotifyRegister := GetProcAddress(ShellLibrary,PChar(2)); SHChangeNotifyUnregister := GetProcAddress(ShellLibrary,PChar(4)); SHChangeNotification_Lock := GetProcAddress(ShellLibrary, PChar(644)); SHChangeNotification_UnLock := GetProcAddress(ShellLibrary, PChar(645)); cxSHGetPathFromIDList := GetProcAddress(ShellLibrary, 'SHGetPathFromIDListA'); cxSHGetPathFromIDListW := GetProcAddress(ShellLibrary, 'SHGetPathFromIDListW'); end; procedure cxShellUninitialize; var I: Integer; begin if FShellItemsInfoGatherers <> nil then for I := 0 to FShellItemsInfoGatherers.Count - 1 do TcxShellItemsInfoGatherer(FShellItemsInfoGatherers[I]).DestroyFetchThread; FcxMalloc := nil; if ShellLibrary <> 0 then FreeLibrary(ShellLibrary); FreeAndNil(FShellLock); if FComInitializationSucceeded then OleUninitialize; end; initialization cxShellInitialize; finalization cxShellUninitialize; end.