unit MPShellUtilities; // Version 1.7.0 // // The contents of this file are subject to the Mozilla Public License // Version 1.1 (the "License"); you may not use this file except in compliance // with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ // // Alternatively, you may redistribute this library, use and/or modify it under the terms of the // GNU Lesser General Public License as published by the Free Software Foundation; // either version 2.1 of the License, or (at your option) any later version. // You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. // // Software distributed under the License is distributed on an "AS IS" basis, // WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the // specific language governing rights and limitations under the License. // // The initial developer of this code is Jim Kueneman // //---------------------------------------------------------------------------- // // Credits for valuable information and code gathered from newsgroups and // websites: // Angus Johnson for his GetDiskFreeSpaceFAT32 function from UNDO // //---------------------------------------------------------------------------- interface {$I ..\Include\Addins.inc} {.$DEFINE GXDEBUG_DEFMENUCREATE_CALLBACK} {.$DEFINE GXDEBUG_VIRTUALCONTEXTMENU} {$IFDEF GXDEBUG_VIRTUALCONTEXTMENU} {$DEFINE GX_DEBUG} {$ENDIF} {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} {$DEFINE GX_DEBUG} {$ENDIF} {$B-} {$include Compilers.inc} {$include Options.inc} uses {$IFDEF GX_DEBUG} DbugIntf, {$ENDIF} Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, ImgList, ShlObj, ShellAPI, ActiveX, Registry, MPShellTypes, MPCommonObjects, MPCommonUtilities, MPThreadManager, MPResources, MPDataObject, {$IFDEF TNTSUPPORT} TntSysUtils, TntClasses, TntRegistry, TntMenus, {$ENDIF} {$IFDEF COMPILER_6_UP} Variants, {$ENDIF} {$IFDEF COMPILER_5_UP} Contnrs, {$ENDIF} Menus; const DefaultDetailColumns = 5; ID_TIMER_NOTIFY = 100; ID_TIMER_ENUMBKGND = 101; ID_TIMER_AUTOSCROLL = 102; ID_TIMER_SHELLNOTIFY = 103; SHORTCUT_ICON_INDEX = 29; // This is cheezy crappy stupid and dumb but // I can't find a way to get the link index SHELL_NAMESPACE_ID = -1; // ID of a basic Shell Namespace based TNamespace SHGDN_FOREDITING = $1000; DEFAULTPIDLARRAYSIZE = 8192; // Default size for the TPIDLArray STREAM_VERSION_DEFAULT = -1; // Default Stream version for TStreamableClass.LoadFromStream // if this value is seen the LoadFromStream method should read the version // from the stream else it should use the passed version in the method STR_IMAGE_THREAD_EVENT = 'jdkImageThreadEvent'; VET_DEFAULT_COLUMNWIDTHS: array[0..36] of integer = ( 180, // Name 96, // Size 120, // Type 120, // Modified 60, // Attributes 180, // Comment 120, // Created 120, // Accessed 120, // Owner 120, // Author 120, // Title 120, // Subject 120, // Catagory 60, // Pages 120, // Copywrite 120, // Company Name 120, // Module Description 120, // Module Version 120, // Product Name 120, // Product Version 72, // Sender Name 90, // Recipient Name 102, // Recipient Number 30, // Csid 30, // Tsid 108, // Transmission Time 60, // Caller ID 48, // Routing 180, // Audio Format 180, // Sample Rate 180, // Audio Sample Size 180, // Channels 180, // Play Length 180, // Frame Count 180, // Frame Rate 180, // Video Sample Size 180 // Video Compression ); VET_DEFAULT_DRIVES_COLUMNWIDTHS: array[0..3] of integer = ( 180, // Name 120, // Type 96, // Total Size 96 // Free Space ); VET_DEFAULT_CONTROLPANEL_COLUMNWIDTHS: array[0..1] of integer = ( 180, // Name 300 // Description ); VET_DEFAULT_NETWORK_COLUMNWIDTHS: array[0..1] of integer = ( 180, // Name 300 // Description ); {-------------------------------------------------------------------------------} { Custom enumerated types } {-------------------------------------------------------------------------------} type TDefaultFolderIcon = ( diNormalFolder, // Retrieve the index for a normal file folder icon diOpenFolder, // Retrieve the index for a normal file folder icon in the open state diUnknownFile, // Retrieve the index for an icon for a file that has no association diLink, // Retrieve the index for link overlay icon diMyDocuments // Index of MyDocuments icon ); TMPBrowseFlag = ( mpbfComputers, // Only allow computers to be returned mpbfPrinters, // Only allow printers to be returned mpbfDontGoBelowDomain, // Don't allow browsing into other network domains mpbfFileSysAncestors, // Only allow File system ancestors to be returned mpbfFileSysFolder, // Only allow file system folders to be returned // mpbfIncludeStatusText, // Includes status test in the dialog mpbfIncludeFiles, // Include files mpbfNewStyleDialog, // New style dialog mpbfEditBox, // Add a edtibox for the use to type into mpbfIncludeURLs, // Include URLs mpbfSharable, // sharable folders mpbfMustExist // Returned folder must exist or cancel pressed before dialog will close ); TMPBrowseFlags = set of TMPBrowseFlag; type TNamespaceState = ( nsFreePIDLOnDestroy, // If true the object free the PIDL with the system allocator when freed nsIsRecycleBin, // Recyclebin does not cooperate very well so we have do extra checks for various reasons so cache this nsRecycleBinChecked, // Flag to see if above is valid. nsOwnsParent, // If a namespace is created from a complex PIDL for some methods the parent is needed. If so a Parent namespace is created so this instance owns it and must free it. nsShellDetailsSupported, // Instead of a costly call to see if interface exists when it does not we only check once then cache the result nsShellFolder2Supported, // Same idea as ShellDetailsSupported, if it does not exist don't waste time constantly checking nsShellOverlaySupported, // Same idea as ShellDetailsSupported, if it does not exist don't waste time constantly checking nsThreadedIconLoaded, // To keep the threaded icon option fast and interuptable need to track if a thread is currently trying to extract the namespace icon index. Retrieved. nsThreadedIconLoading, // To keep the threaded icon option fast and interuptable need to track if a thread is currently trying to extract the namespace icon index. In queue. nsThreadedImageLoaded, // To keep the threaded image option fast and interuptable need to track if a thread is currently trying to extract the namespace thumbnail. Retrieved. nsThreadedImageLoading, // To keep the threaded image option fast and interuptable need to track if a thread is currently trying to extract the namespace thumbnail. In queue. nsThreadedImageResizing, // To keep the threaded image option fast and interuptable need to track if a thread is currently trying to resize the namespace thumbnail. In queue. nsThreadedTileInfoLoaded, // To keep the threaded Tile Info option fast and interuptable need to track if a thread is currently trying to extract Tile Info for the namespace, Threaded Tile Info is retrieved nsThreadedTileInfoLoading, // To keeping the threaded Tile Info option fast and interuptable need to track if a thread is currently trying to extract Tile Info for the namespace, it is in the queue to be retieved nsIconIndexChanged // Sets a flag to track when the IconIndex changed between calls to GetIconIndex. Usually caused by a Thread Setting the icon index ); TNamespaceStates = set of TNamespaceState; type // {$HPPEMIT 'class TNamespace;'} TSHLimitInputEdit = function(hWndEdit: HWND; psf: IShellFolder): HRESULT; stdcall; {$IFNDEF CPPB_6_UP} IVETShellDetails = IShellDetails; {$ELSE} IVETShellDetails = IShellDetailsBCB6; {$ENDIF} TShellCache = set of ( // Valid entries in the Namespace data cache scInFolderName, scNormalName, scParsedName, scSmallIcon, scSmallOpenIcon, scOverlayIndex, scCreationTime, scLastAccessTime, scLastWriteTime, scFileSize, scFileSizeKB, scFileSizeInt64, scFileType, scInvalidIDListData, // If SHGetDataFromIDList fails flag it so we won't try again. scFileSystem, scFolder, scCanDelete, scCanRename, scGhosted, scCanCopy, scCanMove, scCanLink, scLink, scFileSysAncestor, scCompressed, scFileTimes, scSupportedColumns, scFolderSize, // Recursivly calculated size of folder contents scVirtualHook, // Namespace is the invisible parent of the RootVirtualNamespace scHookedNamespace, // Namespace has custom sub items injected through SubFolderHook property scVirtualNamespace, // Namespace is a virtual namespace scRootVirtualNamespace, // Namespace is the Root of the Custom Namespace Branch. If a real NS is hooked it is the namespace under the caSubItemHook namespace scHardHookedNamespace, // Namespace is a hard hooked, this means it will show user defined details if defined instead of using the real namespaces parent to create the details scDetailsOfCache, scBrowsable ); { This stores the state of the cached folder attribute. } TCacheAttributes = set of ( caFileSystem, // Namespace is part of the file system caFolder, // Namespace is a Folder (not necessarily a directory) caCanDelete, // Namespace can be deleted caCanRename, // Namespace can be renamed caGhosted, // Namespace is should display a ghosted icon caCanCopy, // Namespace can be copied caCanMove, // Namespace can be moved to a different location caCanLink, // Namespace can create a link to itself caLink, // Namespace *is* a link caFileSysAncestor, // Namespace is an ancestor of a file system namespace caCompressed, // Namespace represents a compressed folder caVirtualHook, // Namespace is the invisible parent of the RootVirtualNamespace caHookedNamespace, // Namespace has custom sub items injected through SubFolderHook property caVirtualNamespace, // Namespace is a virtual namespace caRootVirtualNamespace, // Namespace is the Root of the Custom Namespace Branch. If a real NS is hooked it is the namespace under the caSubItemHook namespace caHardHookedNamespace, // Namespace is a hard hooked, this means it will show user defined details if defined instead of using the real namespaces parent to create the details caBrowsable ); { Used in IShellFolder2.GetDefaultColumnState } TSHColumnState = ( csTypeString, // A string. csTypeInt, // An integer. csTypeDate, // A date. csOnByDefault, // Should be shown by default in the Microsoft® Windows® Explorer Details view. csSlow, // Extracting information about the column can be time consuming. csExtended, // Provided by a handler, not the folder object. csSecondaryUI, // Not displayed in the context menu, but listed in the More dialog box. csHidden // Not displayed in the user interface. ); TSHColumnStates = set of TSHColumnState; THotKeyModifier = ( // For IShellLink hkmAlt, // HOTKEYF_ALT hkmControl, // HOTKEYF_CONTROL hkmExtendedKey, // HOTKEYF_EXT hkmShift // HOTKEYF_SHIFT ); THotKeyModifiers = set of THotKeyModifier; TCmdShow = ( // For IShellLink swHide, // Hides the window and activates another window. swMaximize, // Maximizes the specified window. swMinimize, // Minimizes the specified window and activates the next top-level window in the Z order. swRestore, // Activates and displays the window. If the window is minimized or maximized, Windows restores it to its original size and position. An application should specify this flag when restoring a minimized window. swShow, // Activates the window and displays it in its current size and position. swShowDefault, // Sets the show state based on the SW_ flag specified in the STARTUPINFO structure passed to the CreateProcess function by the program that started the application. swShowMinimized, // Activates the window and displays it as a minimized window. swShowMinNoActive, // Displays the window as a minimized window. The active window remains active. swShowNA, // Displays the window in its current state. The active window remains active. swShowNoActive, // Displays a window in its most recent size and position. The active window remains active. swShowNormal // Activates and displays a window. If the window is minimized or maximized, Windows ); // restores it to its original size and position. An application should specify this flag // when displaying the window for the first time. TIconSize = ( icSmall, // Small Shell size icon, usually 16x16 icLarge // Large TListview size Icon, usually 32x32 ); TFileSort = ( // Used in the ShellSortHelper class fsFileType, // Sort by the File Type name fsFileExtension // Sort by the file extenstion ); TObjectDescription = ( // Return from SHGetDataFromIDList with SHGDFIL_DESCRIPTIONID param odError, // The call Failed for some reason odRootRegistered, // The item is a registered item on the desktop. odFile, // The item is a file. odDirectory, // The item is a folder. odUnidentifiedFileItem, // The item is an unidentified item in the file system. od35Floppy, // The item is a 3.5-inch floppy drive. od525Floppy, // The item is a 5.25-inch floppy drive. odRemovableDisk, // The item is a removable disk drive. odFixedDrive, // The item is a fixed disk drive. odMappedDrive, // The item is a drive that is mapped to a network share. odCDROMDrive, // The item is a CD-ROM drive. odRAMDisk, // The item is a RAM disk. odUnidentifiedDevice, // The item is an unidentified system device. odNetworkDomain, // The item is a network domain. odNetworkServer, // The item is a network server. odNetworkShare, // The item is a network share. odNetworkRestOfNet, // Not currently used. odUnidentifiedNetwork, // The item is an unidentified network resource. odComputerImaging, // Not currently used. odComputerAudio, // Not currently used. odShareDocuments // The item is the system shared documents folder. ); TDetailsColumnTitleInfo = ( tiCenterAlign, // The header title is Center Aligned tiLeftAlign, // The header title is Left Aligned tiRightAlign, // The header title is Right Aligned tiContainsImage // The header title is Contains an Image (were do you get the image???) ); { Selects what type of namespaces are enumerated and displayed in VET. } TFileObjects = set of ( foFolders, foNonFolders, foHidden, foShareable, foNetworkPrinters ); TSHColumnIDArray = array of TSHColumnID; TGUIDArray = array of TGUID; TWideStringArray = array of WideString; TCategoryArray = array of ICategorizer; TCategoryInfo = record Description: WideString; Collapsed: Boolean; Hidden: Boolean; end; TCategoryInfoArray = array of TCategoryInfo; TBooleanArray = array of Boolean; TCategoriesInfo = record ColumnID: TSHColumnIDArray; CatGUID: TGUIDArray; CategoryNames: TWideStringArray; Categories: TCategoryInfoArray; CanCatatorize: TBooleanArray; DefaultColumn: Integer; // Index into above arrays to the default grouping column CategoryCount: Integer; end; TBtyeSize = ( bsKiloBytes, bsMegaBytes, bsGigiBytes, bsTereBytes, bsCustom ); {-------------------------------------------------------------------------------} {-------------------------------------------------------------------------------} { Custom Data structures } {-------------------------------------------------------------------------------} type TNamespace = class; // Forward TExtractImage = class; // Forward TCommonShellContextMenu = class; // Forward TMenuItemIDArray = array of cardinal; TVisibleColumnIndexArray = array of Word; // Array of the column indexes that are currently visible for a namespace { Array that contains the cached information for the folder. } TDetailsOfCacheFlag = ( docCaptionValid, docStatesValid, docThreadLoading, docThreadLoaded ); TDetailsOfCacheFlags = set of TDetailsOfCacheFlag; PDetailsOfCacheRec = ^TDetailsOfCacheRec; TDetailsOfCacheRec = packed record Cached: TDetailsOfCacheFlags; Caption: WideString; States: TSHColumnStates; end; TDetailsOfCacheArray = array of TDetailsOfCacheRec; TCacheData = packed record Attributes: TCacheAttributes; // Boolean attributes for the namespace are saved as bits SmallIcon, // Index in the ShellImageList of the normal icon SmallOpenIcon: integer; // Index in the ShellImageList of the open or selected icon InFolderName, // InFolder display name for the namespace NormalName, // Normal display name for the namespace ParsedName, // The Path of the namespace if it is a file object, if not it is usually the same as NameNormal CreationTime, // String of the object creation time in details mode LastAccessTime, // String of the last accessed time in details mode LastWriteTime, // String of the last write time in details mode FileSize, // String of the file size "23,0000" FileSizeKB, // String of the file size ala Explorer style i.e. "23 KB" FileType: WideString; // @@@@ FileType shown in Explorer details mode FileSizeInt64: Int64; // Actual File Size SupportedColumns: integer; // Number of supported columns in details mode FolderSize: Int64; // Recursivly calcuated size of folder contents OverlayIndex, // Cache the Index of the Overlay OverlayIconIndex: Integer; // Cache the Index of the Overlay Icon DetailsOfCache: TDetailsOfCacheArray // Cached strings for report view end; { Cache record tracks which information in the Data structure is valid with the } { ShellCacheFlags. } TShellCacheRec = packed record ShellCacheFlags: TShellCache; // If flag is set the corresponding data stored in Data is valid Data: TCacheData; // Cached data for fast retrieval end; PSHGetFileInfoRec = ^TSHGetFileInfoRec; TSHGetFileInfoRec = packed record FileType: WideString; // Holds the File Type column detail if not using ShellColumns (using VET or custom columns) end; TShellContextMenuFlag = ( cmfCanRename, // This flag is set if the calling application supports renaming of items. A shortcut menu extension or drag-and-drop handler should ignore this flag. A namespace extension should add a rename item to the menu if applicable. cmfDefaultOnly, // This flag is set when the user is activating the default action, typically by double-clicking. This flag provides a hint for the shortcut menu extension to add nothing if it does not modify the default item in the menu. A shortcut menu extension or drag-and-drop handler should not add any menu items if this value is specified. A namespace extension should add only the default item (if any). // cmfDisableVerbs, // Microsoft Windows Vista and later: This flag is set when the calling application wants to invoke verbs that are otherwise disabled, such as legacy menus. cmfExplore, // This flag is set when the Microsoft Windows Explorer tree window is present. cmfExtendedVerbs, // This flag is set when the calling application wants extended verbs. Normal verbs are displayed when the user right-clicks an object. To display extended verbs, the user must right-click while pressing the SHIFT key. cmfIncludeStatic, // Deprecated, do not use. cmfItemMenu, // Microsoft Windows Vista and later: This flag is set when the calling application is invoking a context menu on an item in the view (as opposed to the background of the view). cmfNoDefault, // This flag is set if no item in the menu has been set as the default. A drag-and-drop handler should ignore this flag. A namespace extension should not set any of the menu items to the default. cmfNormal, // Indicates normal operation. A shortcut menu extension, namespace extension, or drag-and-drop handler can add all menu items. cmfNoVerbs, // This flag is set for items displayed in the Send To menu. Shortcut menu handlers should ignore this value. cmfVerbsOnly // This flag is set if the shortcut menu is for a shortcut object. Shortcut menu handlers should ignore this value. ); TShellContextMenuFlags = set of TShellContextMenuFlag; TNamespaceArray = array of TNamespace; TCommonShellMenuEvent = procedure(Sender: TCommonShellContextMenu) of object; {$IFDEF TNTSUPPORT} TCommonShellMenuInvokeEvent = procedure(Sender: TCommonShellContextMenu; MenuItem: TTntMenuItem; InvokeInfo: PCMInvokeCommandInfo; var Handled: Boolean) of object; {$ELSE} TCommonShellMenuInvokeEvent = procedure(Sender: TCommonShellContextMenu; MenuItem: TMenuItem; InvokeInfo: PCMInvokeCommandInfo; var Handled: Boolean) of object; {$ENDIF} TCommonShellMenuMergeEvent = procedure(Sender: TCommonShellContextMenu; Menu: HMENU; IndexMenu: UINT; var CmdFirst: UINT; CmdLast: UINT; Flags: TShellContextMenuFlags) of object; TCommonShellMenuItemEvent = procedure(Sender: TCommonShellContextMenu; ShellFolder: IShellFolder; DataObject: IDataObject; var Handled: Boolean) of object; TCommonShellMenuNewItemEvent = procedure(Sender: TCommonShellContextMenu; NS: TNamespace) of object; TCommonShellMenuCopyEvent = TCommonShellMenuItemEvent; TCommonShellMenuCreateShortcutEvent = TCommonShellMenuItemEvent; TCommonShellMenuCutEvent = TCommonShellMenuItemEvent; TCommonShellMenuDeleteEvent = TCommonShellMenuItemEvent; TCommonShellMenuNewFolderEvent = TCommonShellMenuItemEvent; TCommonShellMenuPasteEvent = TCommonShellMenuItemEvent; TCommonShellMenuPasteLinkEvent = TCommonShellMenuItemEvent; TCommonShellMenuPasteShortCutEvent = TCommonShellMenuItemEvent; TCommonShellMenuProperitesEvent = TCommonShellMenuItemEvent; {-------------------------------------------------------------------------------} // Custom Exceptions EVSTInvalidFileName = class(Exception) end; {-------------------------------------------------------------------------------} { Persistent Storing and Recreating VET } {-------------------------------------------------------------------------------} TStreamableClass = class(TPersistent) private FStreamVersion: integer; public constructor Create; procedure LoadFromFile(FileName: WideString; Version: integer = 0; ReadVerFromStream: Boolean = False); virtual; procedure LoadFromStream(S: TStream; Version: integer = 0; ReadVerFromStream: Boolean = False); virtual; procedure SaveToFile(FileName: WideString; Version: integer = 0; ReadVerFromStream: Boolean = False); virtual; procedure SaveToStream(S: TStream; Version: integer = 0; WriteVerToStream: Boolean = False); virtual; property StreamVersion: integer read FStreamVersion; end; TStreamableList = class(TList) private FStreamVersion: integer; public constructor Create; procedure LoadFromFile(FileName: WideString; Version: integer = 0; ReadVerFromStream: Boolean = False); virtual; procedure LoadFromStream(S: TStream; Version: integer = 0; ReadVerFromStream: Boolean = False); virtual; procedure SaveToFile(FileName: WideString; Version: integer = 0; ReadVerFromStream: Boolean = False); virtual; procedure SaveToStream(S: TStream; Version: integer = 0; WriteVerToStream: Boolean = False); virtual; property StreamVersion: integer read FStreamVersion; end; {-------------------------------------------------------------------------------} {-------------------------------------------------------------------------------} { Our own COM like referenced classes } {-------------------------------------------------------------------------------} TReferenceCounted = class protected FRefCount: integer; public procedure AddRef; procedure Release; end; { Reference counted TList, much like a COM object but the compiler does not } { add the AddRef and Release call automaticlly. } TReferenceCountedList = class(TList) protected FRefCount: integer; public procedure AddRef; procedure Release; property RefCount: integer read FRefCount; end; {-------------------------------------------------------------------------------} { Encapsulates IExtractImage, ASCI and Unicode } {-------------------------------------------------------------------------------} TExtractImage = class private FFlags: Longword; // Sets how the image is to be handled see IEIFLAG_xxxx FPriority: Longword; // Returns from GetLocation call the priority if IEIFLAG_ASYNC is used above FHeight: Longword; // Desired image height FWidth: Longword; // Desired image Width FColorDepth: Longword; // Desired color depth FExtractImageInterface: IExtractImage; // The interface FExtractImage2Interface: IExtractImage2; // The interface for image2 FOwner: TNamespace; // The Owner namespace FPathExtracted: Boolean; function GetImage: TBitmap; function GetImagePath: WideString; function GetExtractImageInterface: IExtractImage; function GetExtractImageInterface2: IExtractImage2; protected property PathExtracted: Boolean read FPathExtracted write FPathExtracted; public constructor Create; property ColorDepth: Longword read FColorDepth write FColorDepth; property ImagePath: WideString read GetImagePath; property Image: TBitmap read GetImage; property ExtractImageInterface: IExtractImage read GetExtractImageInterface; property ExtractImage2Interface: IExtractImage2 read GetExtractImageInterface2; property Flags: Longword read FFlags write FFlags; property Height: Longword read FHeight write FHeight; property Owner: TNamespace read FOwner write FOwner; property Priority: Longword read FPriority; property Width: Longword read FWidth write FWidth; end; {-------------------------------------------------------------------------------} {-------------------------------------------------------------------------------} { Encapsulates IShellLink, ASCI and Unicode } {-------------------------------------------------------------------------------} TVirtualShellLink = class(TComponent) private FFileName: WideString; // File name of the lnk file FShellLinkA: IShellLink; // ShellLink interface FShellLinkW: IShellLinkW; // ShellLinkW interface FIconIndex: integer; // Index of the icon to be used with the link FTargetIDList: PItemIDList; // If the Target is a virtual object the PIDL is the only way to make the link FShowCmd: TCmdShow; // How to show the window of the target application FHotKeyModifiers: THotKeyModifiers; // The key modifiers for short cuts FTargetPath: WideString; // The target that will be executed FArguments: WideString; // Any arguments to be passed to the target FDescription: WideString; // A description that will be shown in the properties dialog FWorkingDirectory: WideString; // The directory the target application will have set as its current directory FIconLocation: WideString; // The file that has the icon for the link FHotKey: Word; // The HotKey to execute the link, used with the FHotKeyModifiers FSilentWrite: Boolean; // Do not check parameters before writing lnk file and show a warning function GetShellLinkAInterface: IShellLinkA; function GetShellLinkWInterface: IShellLinkW; protected procedure FreeTargetIDList; public destructor Destroy; override; function ReadLink(LinkFileName: WideString): Boolean; function WriteLink(LinkFileName: WideString): Boolean; property Arguments: WideString read FArguments write FArguments; property Description: WideString read FDescription write FDescription; property FileName: WideString read FFileName write FFileName; property HotKey: Word read FHotKey write FHotKey; property HotKeyModifiers: THotKeyModifiers read FHotKeyModifiers write FHotKeyModifiers; property IconIndex: integer read FIconIndex write FIconIndex; property IconLocation: WideString read FIconLocation write FIconLocation; property TargetIDList: PItemIDList read FTargetIDList write FTargetIDList; property ShellLinkAInterface: IShellLink read GetShellLinkAInterface; property ShellLinkWInterface: IShellLinkW read GetShellLinkWInterface; property ShowCmd: TCmdShow read FShowCmd write FShowCmd; // SW_XXXX contants property SilentWrite: Boolean read FSilentWrite write FSilentWrite; property TargetPath: WideString read FTargetPath write FTargetPath; property WorkingDirectory: WideString read FWorkingDirectory write FWorkingDirectory; end; {-------------------------------------------------------------------------------} // General helper class to sort Shell related objects. Uses mainly to sort // columns in details mode TShellSortHelper = class private FFileSort: TFileSort; // Defines if SortType sorts by the type string or the file extension public function CompareIDSort(SortColumn: integer; NS1, NS2: TNamespace): Integer; virtual; function DiscriminateFolders(NS1, NS2: TNamespace): Integer; virtual; function SortFileSize(NS1, NS2: TNamespace): Integer; virtual; function SortFileTime(FT1, FT2: TFileTime; NS1, NS2: TNamespace): Integer; virtual; function SortString(S1, S2: WideString; NS1, NS2: TNamespace): Integer; virtual; function SortType(NS1, NS2: TNamespace): Integer; virtual; property FileSort: TFileSort read FFileSort write FFileSort; end; {-------------------------------------------------------------------------------} { Function definitions } {-------------------------------------------------------------------------------} // Return True if VT adds a node to the tree this keeps the item count returned // by TNamespace.EnumFolder correct. To stop the enumeration set Terminate to true TEnumFolderCallback = function(MessageWnd: HWnd; APIDL: PItemIDList; AParent: TNamespace; Data: Pointer; var Terminate: Boolean): Boolean of object; TContextMenuCmdCallback = procedure(Namespace: TNamespace; Verb: WideString; MenuItemID: Integer; var Handled: Boolean) of object; TContextMenuShowCallback = procedure(Namespace: TNamespace; Menu: hMenu; var Allow: Boolean) of object; TContextMenuAfterCmdCallback = procedure(Namespace: TNamespace; Verb: WideString; MenuItemID: Integer; Successful: Boolean) of object; {-------------------------------------------------------------------------------} {-------------------------------------------------------------------------------} { TNamespace, encapsulates the Windows Shell Namespace } {-------------------------------------------------------------------------------} { TNamespace is a class that encapsulates the IShellFolder interface. It } { simplifies shell interfaces by hiding the overhead of PIDLs and COM. } { Most properties and methods have a direct corrolation to the functions } { exposed by IShellFolder. } TNamespace = class private FAbsolutePIDL: PItemIDList; // The Absolute PIDL of that represents the namespace FCatInfo: TCategoriesInfo; FCurrentContextMenu: IContextMenu; // The basic interface to create a shell context menu, need to save because of ownerdraw callbacks (maybe this one is not necessary IContextMenu2 only supports this) FCurrentContextMenu2: IContextMenu2; // Extends the context menu interface to include ownerdraw items, need to save because of ownerdraw callbacks FDropTargetInterface: IDropTarget; // Interface to handle a drag Drop on the namespace FExtractImage: TExtractImage; // Encapsulate the seldom used IExtractImage inteface saving memory allocation in the TNamespace when not used FImage: TBitmap; // The image extracted from the IExtractImage interface FNamespaceID: integer; // ID of the namespace. Used to pick out any custom namespace objects from real shell supplied ones FOldWndProcForContextMenu: TWndMethod; // OldWndProc of the ContextMenu owner used in InternalShowContextMenu FParent: TNamespace; // The parent of this namespace, may be owned by this decenant see OwnsParent property FRelativePIDL: PItemIDList; // The relative PILD that can be used the the ParentNamespace. It is a pointer to the last ID of of AbsolutePILD so *don't* free it FShellDetailsInterface: IVETShellDetails; // Interface to deal with the information in the columns in details view (superceded by IShellFolder2 ) FShellFolder: IShellFolder; // IShellFolder is the building block interface that defines the namespaces attributes FShellFolder2: IShellFolder2; // Expands IShellFolder handling the column details in Details mode, only works on Win2k-WinMe and up FShellIconInterface: IShellIcon; // Interface to extract only the index of the icon in the system imagelist FShellLink: TVirtualShellLink; // Object to read and write attributes to shortcut namespaces (files) FSHGetFileInfoRec: PSHGetFileInfoRec; // Stores cached info from a call to SHGetFileInfo(A or W) FStates: TNamespaceStates; // Dynamic state of the TNamespace FTag: integer; FTileDetail: TCommonIntegerDynArray; // FQueryInfoInterface: IQueryInfo; // Interface for the popup InfoTips on folders in Win2k-WinME and up FWin32FindDataA: PWin32FindDataA; // pointer to an allocated structure for an ASCI window file information if is is a file object FWin32FindDataW: PWin32FindDataW; // pointer to an allocated structure for an Unicode window file information if is is a file object FSystemIsSuperHidden: Boolean; // Holds the result of if the system has the SuperHiddenFile flag set in the registry FShellIconOverlayInterface: IShellIconOverlay; FCategoryProviderInterface: ICategoryProvider; FBrowserFrameOptionsInterface: IBrowserFrameOptions; FQueryAssociationsInterface: IQueryAssociations; function GetCategoryCount: Integer; function GetParent: TNamespace; protected { Make the Cache Data and property getters available to decendants. This } { will allow decendants of TNamespace to be created so "virtual namespaces" } { can be created. It is possible to create a "namespace extension" without } { really doing it! } { None of interface properties are here because they only make sense for } { actual COM namespaces. } FShellCache: TShellCacheRec; { Virtual Property Setters } function GetArchive: Boolean; virtual; function GetAttributesString: WideString; virtual; function GetBrowsable: Boolean; virtual; function GetBrowserFrameOptionsInterface: IBrowserFrameOptions; virtual; function GetCanCopy: Boolean; virtual; function GetCanDelete: Boolean; virtual; function GetCanLink: Boolean; virtual; function GetCanMoniker: Boolean; virtual; function GetCanMove: Boolean; virtual; function GetCanRename: Boolean; virtual; function GetCategoryProviderInterface: ICategoryProvider; virtual; function GetCLSID: TGUID; virtual; function GetCompressed: Boolean; virtual; function GetContextMenu2Interface: IContextMenu2; virtual; function GetContextMenu3Interface: IContextMenu3; virtual; function GetContextMenuInterface: IContextMenu; virtual; function GetCreationDateTime: TDateTime; virtual; function GetCreationTime: WideString; virtual; function GetCreationTimeRaw: TFileTime; virtual; function GetDataObjectInterface: IDataObject; virtual; function GetDescription: TObjectDescription; virtual; function GetDetailsSupported: Boolean; virtual; function GetDirectory: Boolean; virtual; function GetDropTarget: Boolean; virtual; function GetDropTargetInterface: IDropTarget; virtual; function GetEncrypted: Boolean; virtual; function GetExtension: WideString; virtual; function GetExtractIconAInterface: IExtractIconA; virtual; function GetExtractIconWInterface: IExtractIconW; virtual; function GetExtractImage: TExtractImage; virtual; function GetFileName: WideString; virtual; function GetFileSysAncestor: Boolean; virtual; function GetFileSystem: Boolean; virtual; function GetFileType: WideString; virtual; function GetFolder: Boolean; virtual; function GetFreePIDLOnDestroy: Boolean; virtual; function GetGhosted: Boolean; virtual; function GetHasPropSheet: Boolean; virtual; function GetHasStorage: Boolean; virtual; function GetHasSubFolder: Boolean; virtual; function GetHidden: Boolean; virtual; function GetIconIndexChanged: Boolean; virtual; function GetInfoTip: WideString; virtual; function GetIsSlow: Boolean; virtual; function GetLastAccessDateTime: TDateTime; virtual; function GetLastAccessTime: WideString; virtual; function GetLastAccessTimeRaw: TFileTime; virtual; function GetLastWriteDateTime: TDateTime; virtual; function GetLastWriteTime: WideString; virtual; function GetLastWriteTimeRaw: TFileTime; virtual; function GetLink: Boolean; virtual; function GetNameAddressbar: WideString; virtual; function GetNameAddressbarInFolder: WideString; virtual; function GetNameForEditing: WideString; virtual; function GetNameForEditingInFolder: WideString; virtual; function GetNameForParsing: WideString; virtual; function GetNameForParsingInFolder: WideString; virtual; function GetNameInFolder: WideString; virtual; function GetNameNormal: WideString; virtual; function GetNameParseAddress: WideString; virtual; function GetNameParseAddressInFolder: WideString; virtual; function GetNewContent: Boolean; virtual; function GetNonEnumerated: Boolean; virtual; function GetNormal: Boolean; virtual; function GetOffLine: Boolean; virtual; function GetOverlayIconIndex: Integer; virtual; function GetOverlayIndex: Integer; virtual; function GetParentShellDetailsInterface: IVETShellDetails; virtual; function GetParentShellFolder: IShellFolder; virtual; function GetParentShellFolder2: IShellFolder2; virtual; function GetQueryAssociationsInterface: IQueryAssociations; virtual; function GetQueryInfoInterface: IQueryInfo;virtual; function GetReadOnly: Boolean; virtual; function GetReadOnlyFile: Boolean; virtual; function GetReparsePoint: Boolean; virtual; function GetRemovable: Boolean; virtual; function GetShare: Boolean; virtual; function GetShellDetailsInterface: IVETShellDetails; virtual; function GetShellFolder: IShellFolder; virtual; function GetShellFolder2: IShellFolder2; virtual; function GetShellIconInterface: IShellIcon; virtual; function GetShellIconOverlayInterface: IShellIconOverlay; virtual; function GetShellLink: TVirtualShellLink; virtual; function GetShortFileName: WideString; virtual; function GetSizeOfFile: WideString; virtual; function GetSizeOfFileDiskUsage: WideString; virtual; function GetSizeOfFileInt64: Int64; virtual; function GetSizeOfFileKB: WideString; virtual; function GetSparseFile: Boolean; virtual; function GetStorage: Boolean; virtual; function GetStorageAncestor: Boolean; virtual; function GetStream: Boolean; virtual; function GetSubFolders: Boolean; virtual; function GetSubItems: Boolean; virtual; function GetSystem: Boolean; virtual; function GetTemporary: Boolean; virtual; function GetThreadedDetailLoaded(ColumnIndex: Integer): Boolean; virtual; function GetThreadedDetailLoading(ColumnIndex: Integer): Boolean; virtual; function GetThreadedIconLoaded: Boolean; virtual; function GetThreadedImageLoaded: Boolean; virtual; function GetThreadedImageLoading: Boolean; virtual; function GetThreadIconLoading: Boolean; virtual; function GetValid: Boolean; virtual; function ParentWnd: HWnd; procedure EnsureDetailCache; procedure ExecuteContextMenuVerbMultiPath(Verb: WideString; Namespaces: TNamespaceArray); procedure LoadCategoryInfo; procedure SetFreePIDLOnDestroy(const Value: Boolean); virtual; procedure SetIconIndexChanged(const Value: Boolean); virtual; procedure SetThreadedDetailLoaded(ColumnIndex: Integer; Value: Boolean); virtual; procedure SetThreadedDetailLoading(ColumnIndex: Integer; Value: Boolean); virtual; procedure SetThreadIconLoading(const Value: Boolean); virtual; procedure SetThreadImageLoading(const Value: Boolean); virtual; function CreateCategory(GUID: TGUID): ICategorizer; function EnumFuncDummy(MessageWnd: HWnd; APIDL: PItemIDList; AParent: TNamespace; Data: Pointer; var Terminate: Boolean): Boolean; function ExplorerStyleAttributeStringList(CapitalLetters: Boolean): WideString; function DisplayNameOf(Flags: Longword): WideString; procedure GetDataFromIDList; procedure GetFileTimes; procedure GetSHFileInfo; function InjectCustomSubMenu(Menu: HMenu; Caption: string; PopupMenu: TPopupMenu; var SubMenu: HMenu): TMenuItemIDArray; function InternalGetContextMenuInterface(PIDLArray: TRelativePIDLArray): IContextMenu; function InternalGetDataObjectInterface(PIDLArray: TRelativePIDLArray): IDataObject; function InternalShowContextMenu(Owner: TWinControl; ContextMenuCmdCallback: TContextMenuCmdCallback; ContextMenuShowCallback: TContextMenuShowCallback; ContextMenuAfterCmdCallback: TContextMenuAfterCmdCallback; PIDLArray: TRelativePIDLArray; Position: PPoint; CustomShellSubMenu: TPopupMenu; CustomSubMenuCaption: WideString): Boolean; function InternalSubItems(Flags: Longword): Boolean; procedure ReplacePIDL(NewPIDL: PItemIDList; AParent: TNamespace); function ShowContextMenuMultiPath(Owner: TWinControl; Focused: TNamespace; Namespaces: TNamespaceArray; Position: PPoint = nil): Boolean; procedure WindowProcForContextMenu(var Message: TMessage); property CatInfo: TCategoriesInfo read FCatInfo write FCatInfo; property CurrentContextMenu2: IContextMenu2 read FCurrentContextMenu2 write FCurrentContextMenu2; property CurrentContextMenu: IContextMenu read FCurrentContextMenu write FCurrentContextMenu; property ShellCache: TShellCacheRec read FShellCache write FShellCache; property SystemIsSuperHidden: Boolean read FSystemIsSuperHidden write FSystemIsSuperHidden; public constructor Create(PIDL: PItemIdList; AParent: TNamespace); destructor Destroy; override; constructor CreateCustomNamespace(CustomID: Integer; AParent: TNamespace); virtual; constructor CreateFromFileName(FileName: WideString); virtual; function CanCopyAll(NamespaceArray: TNamespaceArray): Boolean; virtual; function CanCutAll(NamespaceArray: TNamespaceArray): boolean; virtual; function CanDeleteAll(NamespaceArray: TNamespaceArray): Boolean; virtual; function CanPasteToAll(NamespaceArray: TNamespaceArray): Boolean; virtual; function CanShowPropertiesOfAll(NamespaceArray: TNamespaceArray): Boolean; virtual; function Clone(ReleasePIDLOnDestroy: Boolean): TNameSpace; virtual; function ComparePIDL(PIDLToCompare: PItemIDList; IsAbsolutePIDL: Boolean; Column: Integer = 0): ShortInt; virtual; function ContextMenuItemHelp(MenuItemID: LongWord): WideString; virtual; function ContextMenuVerb(MenuItemID: LongWord): WideString; virtual; function Copy(NamespaceArray: TNamespaceArray): Boolean; virtual; function Cut(NamespaceArray: TNamespaceArray): Boolean; virtual; function DataObjectMulti(NamespaceArray: TNamespaceArray): IDataObject; virtual; function Delete(NamespaceArray: TNamespaceArray): Boolean; virtual; function DetailsAlignment(ColumnIndex: Integer): TAlignment; virtual; function DetailsColumnTitle(ColumnIndex: integer): WideString; virtual; function DetailsDefaultColumnTitle(ColumnIndex: integer): WideString; virtual; function DetailsDefaultOf(ColumnIndex: integer): WideString; virtual; function DetailsDefaultSupportedColumns: integer; virtual; function DetailsGetDefaultColumnState(ColumnIndex: integer): TSHColumnStates; virtual; function DetailsOf(ColumnIndex: integer): WideString; virtual; function DetailsOfEx(ColumnIndex: integer): WideString; virtual; function DetailsSupportedColumns: integer; virtual; function DetailsSupportedVisibleColumns: TVisibleColumnIndexArray; virtual; function DetailsValidIndex(DetailsIndex: integer): Boolean; virtual; function DragEffect(grfKeyState: integer): HRESULT; virtual; function DragEnter(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult; virtual; function DragLeave: HResult; virtual; function DragOver(grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult; virtual; function Drop(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult; virtual; function EnumerateFolder(MessageWnd: HWnd; Folders, NonFolders, IncludeHidden: Boolean; EnumFunc: TEnumFolderCallback; UserData: pointer): integer; virtual; function EnumerateFolderEx(MessageWnd: HWnd; FileObjects: TFileObjects; EnumFunc: TEnumFolderCallback; UserData: pointer; AfterValidEnumIDList: TNotifyEvent = nil): integer; virtual; function ExecuteContextMenuVerb(AVerb: WideString; APIDLArray: TRelativePIDLArray; MessageWindowParent: HWnd = 0): Boolean; virtual; function FolderSize(Invalidate: Boolean; RecurseFolder: Boolean = False): Int64; virtual; function GetIconIndex(OpenIcon: Boolean; IconSize: TIconSize; ForceLoad: Boolean = True): integer; virtual; function GetImage: TBitmap; virtual; function VerifyPIDLRelationship(NamespaceArray: TNamespaceArray; Silent: Boolean = False): Boolean; procedure HandleContextMenuMsg(Msg, wParam, lParam: Longint; var Result: LRESULT); virtual; procedure InvalidateCache; virtual; procedure InvalidateDetailsOfCache(FlushStrings: Boolean); procedure InvalidateNamespace(RefreshIcon: Boolean = True); virtual; procedure InvalidateRelativePIDL(FileObjects: TFileObjects); virtual; procedure InvalidateThumbImage; virtual; function IsChildByNamespace(TestNamespace: TNamespace; Immediate: Boolean): Boolean; virtual; function IsChildByPIDL(TestPIDL: PItemIDList; Immediate: Boolean): Boolean; virtual; function IsChildOfRemovableDrive: Boolean; virtual; function IsControlPanel: Boolean; virtual; function IsControlPanelChildFolder: Boolean; virtual; function IsDesktop: Boolean; virtual; function IsMyComputer: Boolean; virtual; function IsNetworkNeighborhood: Boolean; virtual; function IsNetworkNeighborhoodChild: Boolean; virtual; function IsParentByNamespace(TestNamespace: TNamespace; Immediate: Boolean): Boolean; virtual; function IsParentByPIDL(TestPIDL: PItemIDList; Immediate: Boolean): Boolean; virtual; function IsRecycleBin: Boolean; function OkToBrowse(ShowExplorerMsg: Boolean): Boolean; virtual; function ParseDisplayName: PItemIDList; overload; virtual; function ParseDisplayName(Path: WideString): PItemIDList; overload; virtual; function Paste(NamespaceArray: TNamespaceArray; AsShortCut: Boolean = False): Boolean; virtual; procedure SetDetailByThread(ColumnIndex: Integer; Detail: WideString); procedure SetIconIndexByThread(IconIndex: Integer; ClearThreadLoading: Boolean); virtual; procedure SetImageByThread(Bitmap: TBitmap; ClearThreadLoading: Boolean); virtual; function SetNameOf(NewName: WideString): Boolean; virtual; function ShellExecuteNamespace(WorkingDir, CmdLineArguments: WideString; ExecuteFolder: Boolean = False; ExecuteFolderShortCut: Boolean = False; RunInThread: Boolean = False): Boolean; virtual; function ShowContextMenu(Owner: TWinControl; ContextMenuCmdCallback: TContextMenuCmdCallback; ContextMenuShowCallback: TContextMenuShowCallback; ContextMenuAfterCmdCallback: TContextMenuAfterCmdCallback; Position: PPoint = nil; CustomShellSubMenu: TPopupMenu = nil; CustomSubMenuCaption: WideString = ''): Boolean; virtual; function ShowContextMenuMulti(Owner: TWinControl; ContextMenuCmdCallback: TContextMenuCmdCallback; ContextMenuShowCallback: TContextMenuShowCallback; ContextMenuAfterCmdCallback: TContextMenuAfterCmdCallback; NamespaceArray: TNamespaceArray; Position: PPoint = nil; CustomShellSubMenu: TPopupMenu = nil; CustomSubMenuCaption: WideString = ''): Boolean; virtual; procedure ShowPropertySheet; virtual; procedure ShowPropertySheetMulti(NamespaceArray: TNamespaceArray; UseSHMultiFileProperties: Boolean = True; ForceNonMultiPath: Boolean = False); virtual; function SubFoldersEx(Flags: Longword = SHCONTF_FOLDERS): Boolean; virtual; function SubItemsEx(Flags: Longword = SHCONTF_NONFOLDERS): Boolean; virtual; function TestAttributesOf(Flags: Longword; FlushCache: Boolean; SoftFlush: Boolean = False): Boolean; virtual; property AbsolutePIDL: PItemIDList read FAbsolutePIDL write FAbsolutePIDL; property AdvDetailsSupported: Boolean read GetDetailsSupported; property Browsable: Boolean read GetBrowsable; property BrowserFrameOptionsInterface: IBrowserFrameOptions read GetBrowserFrameOptionsInterface; property CanCopy: Boolean read GetCanCopy; property CanDelete: Boolean read GetCanDelete; property CanLink: Boolean read GetCanLink; property CanMoniker: Boolean read GetCanMoniker; property CanMove: Boolean read GetCanMove; property CanRename: Boolean read GetCanRename; property CategoryCount: Integer read GetCategoryCount; property CategoryProviderInterface: ICategoryProvider read GetCategoryProviderInterface; property CLSID: TGUID read GetCLSID; property ContextMenuInterface: IContextMenu read GetContextMenuInterface; property ContextMenu2Interface: IContextMenu2 read GetContextMenu2Interface; property ContextMenu3Interface: IContextMenu3 read GetContextMenu3Interface; property DataObjectInterface: IDataObject read GetDataObjectInterface; property Description: TObjectDescription read GetDescription; property DropTarget: Boolean read GetDropTarget; property DropTargetInterface: IDropTarget read GetDropTargetInterface; property Encrypted: Boolean read GetEncrypted; property ExtractImage: TExtractImage read GetExtractImage; property ExtractIconAInterface: IExtractIconA read GetExtractIconAInterface; property ExtractIconWInterface: IExtractIconW read GetExtractIconWInterface; property FileSystem: Boolean read GetFileSystem; property FileSysAncestor: Boolean read GetFileSysAncestor; property Folder: Boolean read GetFolder; property FreePIDLOnDestroy: Boolean read GetFreePIDLOnDestroy write SetFreePIDLOnDestroy; property Ghosted: Boolean read GetGhosted; property HasPropSheet: Boolean read GetHasPropSheet; property HasStorage: Boolean read GetHasStorage; property HasSubFolder: Boolean read GetHasSubFolder; property IconIndexChanged: Boolean read GetIconIndexChanged write SetIconIndexChanged; property IsSlow: Boolean read GetIsSlow; property Link: Boolean read GetLink; property InfoTip: WideString read GetInfoTip; property NameAddressbar: WideString read GetNameAddressbar; property NameAddressbarInFolder: WideString read GetNameAddressbarInFolder; property NameForEditing: WideString read GetNameForEditing; property NameForEditingInFolder: WideString read GetNameForEditingInFolder; property NameForParsing: WideString read GetNameForParsing; property NameForParsingInFolder: WideString read GetNameForParsingInFolder; property NameInFolder: WideString read GetNameInFolder; property NameNormal: WideString read GetNameNormal; property NameParseAddress: WideString read GetNameParseAddress; property NameParseAddressInFolder: WideString read GetNameParseAddressInFolder; property NamespaceID: integer read FNamespaceID; property NewContent: Boolean read GetNewContent; property NonEnumerated: Boolean read GetNonEnumerated; property Parent: TNamespace read GetParent; property ParentShellFolder: IShellFolder read GetParentShellFolder; property ParentShellFolder2: IShellFolder2 read GetParentShellFolder2; property ParentShellDetailsInterface: IVETShellDetails read GetParentShellDetailsInterface; property QueryAssociationsInterface: IQueryAssociations read GetQueryAssociationsInterface; property ReadOnly: Boolean read GetReadOnly; property RelativePIDL: PItemIDList read FRelativePIDL; // Single Item ID of this namespace property Removable: Boolean read GetRemovable; property Share: Boolean read GetShare; property ShellFolder: IShellFolder read GetShellFolder; property ShellFolder2: IShellFolder2 read GetShellFolder2; property ShellDetailsInterface: IVETShellDetails read GetShellDetailsInterface; property ShellLink: TVirtualShellLink read GetShellLink; property ShellIconInterface: IShellIcon read GetShellIconInterface; property ShellIconOverlayInterface: IShellIconOverlay read GetShellIconOverlayInterface; property ShortFileName: WideString read GetShortFileName; property SparseFile: Boolean read GetSparseFile; property States: TNamespaceStates read FStates write FStates; property Storage: Boolean read GetStorage; property StorageAncestor: Boolean read GetStorageAncestor; property Stream: Boolean read GetStream; property SubFolders: Boolean read GetSubFolders; property SubItems: Boolean read GetSubItems; property Tag: integer read FTag write FTag; property ThreadedDetailLoaded[Column: Integer]: Boolean read GetThreadedDetailLoaded write SetThreadedDetailLoaded; property ThreadedDetailLoading[Column: Integer]: Boolean read GetThreadedDetailLoading write SetThreadedDetailLoading; property ThreadedIconLoaded: Boolean read GetThreadedIconLoaded; property ThreadIconLoading: Boolean read GetThreadIconLoading write SetThreadIconLoading; property ThreadImageLoaded: Boolean read GetThreadedImageLoaded; property ThreadImageLoading: Boolean read GetThreadedImageLoading write SetThreadImageLoading; property TileDetail: TCommonIntegerDynArray read FTileDetail write FTileDetail; property QueryInfoInterface: IQueryInfo read GetQueryInfoInterface; property Win32FindDataA: PWin32FindDataA read FWin32FindDataA; property Win32FindDataW: PWin32FindDataW read FWin32FindDataW; { Information on namespaces that are actual files. } property AttributesString: WideString read GetAttributesString; // Explorer type 'RHSA' property Archive: Boolean read GetArchive; property Compressed: Boolean read GetCompressed; property CreationTime: WideString read GetCreationTime; property CreationDateTime: TDateTime read GetCreationDateTime; property CreationTimeRaw: TFileTime read GetCreationTimeRaw; property Directory: Boolean read GetDirectory; property Extension: WideString read GetExtension; property FileName: WideString read GetFileName; property FileType: WideString read GetFileType; property Hidden: Boolean read GetHidden; property LastAccessTime: WideString read GetLastAccessTime; property LastAccessDateTime: TDateTime read GetLastAccessDateTime; property LastAccessTimeRaw: TFileTime read GetLastAccessTimeRaw; property LastWriteTime: WideString read GetLastWriteTime; property LastWriteDateTime: TDateTime read GetLastWriteDateTime; property LastWriteTimeRaw: TFileTime read GetLastWriteTimeRaw; property Normal: Boolean read GetNormal; property OffLine: Boolean read GetOffLine; property OverlayIndex: Integer read GetOverlayIndex; property OverlayIconIndex: Integer read GetOverlayIconIndex; property ReadOnlyFile: Boolean read GetReadOnlyFile; property ReparsePoint: Boolean read GetReparsePoint; property SizeOfFile: WideString read GetSizeOfFile; property SizeOfFileInt64: Int64 read GetSizeOfFileInt64; property SizeOfFileKB: WideString read GetSizeOfFileKB; property SizeOfFileDiskUsage: WideString read GetSizeOfFileDiskUsage; property SystemFile: Boolean read GetSystem; property Temporary: Boolean read GetTemporary; property Valid: Boolean read GetValid; end; {-------------------------------------------------------------------------------} {$IFNDEF COMPILER_5_UP} TObjectList = class(TList) private FOwnsObjects: Boolean; protected function GetItem(Index: Integer): TObject; procedure SetItem(Index: Integer; AObject: TObject); public constructor Create; overload; constructor Create(AOwnsObjects: Boolean); overload; function Add(AObject: TObject): Integer; function Remove(AObject: TObject): Integer; function IndexOf(AObject: TObject): Integer; function FindInstanceOf(AClass: TClass; AExact: Boolean = True; AStartAt: Integer = 0): Integer; procedure Insert(Index: Integer; AObject: TObject); function First: TObject; function Last: TObject; property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects; property Items[Index: Integer]: TObject read GetItem write SetItem; default; end; {$ENDIF} TVirtualNameSpaceList = class(TObjectList) private function GetItems(Index: Integer): TNamespace; procedure SetItems(Index: Integer; ANamespace: TNamespace); public function Add(ANamespace: TNamespace): Integer; procedure FillArray(var NamespaceArray: TNamespaceArray); function IndexOf(ANamespace: TNamespace): Integer; procedure Insert(Index: Integer; ANamespace: TNamespace); property Items[Index: Integer]: TNamespace read GetItems write SetItems; default; end; // // Used to operate on files that are not the immediate children of the parent // for instance in a search list // // This class will only work on a system that has Shell32.dll version 4.71 and // higher. If the system has at least IE 4.0 it should be compatible // // Use this class as the starting point for a custom Shell Context Menu. It // will handle all of the localization of names for you. // It will also handle objects that do not have the same immediate parent such // as in a search list. // // There is some danger to this as the app could free the object while // the shell still has a connection to it through IShellFolder or IDropTarget. // It should be virtually impossible to do this as the shell only connects to // the interfaces during the time the menu is open. PMenuItemLink = ^TMenuItemLink; TMenuItemLink = record MenuID: UINT; {$IFDEF TNTSUPPORT} Item: TTntMenuItem; {$ELSE} Item: TMenuItem {$ENDIF} end; TMenuItemMap = class(TList) protected function Get(Index: Integer): PMenuItemLink; procedure Put(Index: Integer; Item: PMenuItemLink); public function Add: PMenuItemLink; function First: PMenuItemLink; function IndexOf(Item: PMenuItemLink): Integer; procedure Clear; override; function Insert(Index: Integer): PMenuItemLink; reintroduce; function Last: PMenuItemLink; function Remove(Item: PMenuItemLink): Integer; property Items[Index: Integer]: PMenuItemLink read Get write Put; default; end; TCommonShellContextMenu = class(TComponent, IUnknown, IShellFolder, IDropTarget) private FActiveFolder: IShellFolder; FActivePIDLs: TPIDLArray; FCopyValidated: Boolean; FCurrentContextMenu: IContextMenu; FCurrentContextMenu2: IContextMenu2; FCutValidated: Boolean; FExtensions: TCommonShellContextMenuExtensions; FFromDesktop: Boolean; FLocalFocused: TNamespace; FLocalNamespaces: TNamespaceArray; FMenuMap: TMenuItemMap; FOldWndProcForContextMenu: TWndMethod; {$IFDEF TNTSUPPORT} FKeyStrings: TTntStringList; {$ELSE} FKeyStrings: TStringList; {$ENDIF} FOnHide: TCommonShellMenuEvent; FOnInvokeCommand: TCommonShellMenuInvokeEvent; FOnMenuMerge: TCommonShellMenuMergeEvent; FOnMenuMergeBottom: TCommonShellMenuMergeEvent; FOnMenuMergeTop: TCommonShellMenuMergeEvent; FOnShellMenuCopy: TCommonShellMenuCopyEvent; FOnShellMenuCreateShortcut: TCommonShellMenuCreateShortcutEvent; FOnShellMenuCut: TCommonShellMenuCutEvent; FOnShellMenuDelete: TCommonShellMenuDeleteEvent; FOnShellMenuNewFolder: TCommonShellMenuNewFolderEvent; FOnShellMenuPaste: TCommonShellMenuPasteEvent; FOnShellMenuPasteLink: TCommonShellMenuPasteLinkEvent; FOnShellMenuPasteShortCut: TCommonShellMenuPasteShortCutEvent; FOnShellMenuProperites: TCommonShellMenuProperitesEvent; FOnShow: TCommonShellMenuEvent; FRenameMenuItem: Boolean; FStub: Pointer; FPasteMenuItem: Boolean; FUIObjectOfDataObject: IDataObject; FUIObjectOfDropTarget: IDropTarget; protected // IUnknown function QueryInterface(const IID: TGUID; out Obj): HResult; override; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; // IShellFolder function ParseDisplayName(hwndOwner: HWND; pbcReserved: Pointer; lpszDisplayName: POLESTR; out pchEaten: ULONG; out ppidl: PItemIDList; var dwAttributes: ULONG): HResult; stdcall; function EnumObjects(hwndOwner: HWND; grfFlags: DWORD; out EnumIDList: IEnumIDList): HResult; stdcall; function BindToObject(pidl: PItemIDList; pbcReserved: Pointer; const riid: TIID; out ppvOut{$IFNDEF COMPILER_5_UP}: Pointer{$ENDIF}): HResult; stdcall; function BindToStorage(pidl: PItemIDList; pbcReserved: Pointer; const riid: TIID; out ppvObj{$IFNDEF COMPILER_5_UP}: Pointer{$ENDIF}): HResult; stdcall; function CompareIDs(lParam: LPARAM; pidl1, pidl2: PItemIDList): HResult; stdcall; function CreateViewObject(hwndOwner: HWND; const riid: TIID; out ppvOut{$IFNDEF COMPILER_5_UP}: Pointer{$ENDIF}): HResult; stdcall; function GetAttributesOf(cidl: UINT; var apidl: PItemIDList; var rgfInOut: UINT): HResult; stdcall; function GetUIObjectOf(hwndOwner: HWND; cidl: UINT; var apidl: PItemIDList; const riid: TIID; prgfInOut: Pointer; out ppvOut{$IFNDEF COMPILER_5_UP}: Pointer{$ENDIF}): HResult; stdcall; function GetDisplayNameOf(pidl: PItemIDList; uFlags: DWORD; var lpName: TStrRet): HResult; stdcall; function SetNameOf(hwndOwner: HWND; pidl: PItemIDList; lpszName: POLEStr; uFlags: DWORD; var ppidlOut: PItemIDList): HResult; stdcall; // IDropTarget function DragEnter(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall; function DragOver(grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall; function DragLeave: HResult; stdcall; function Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall; function DefMenuCreateCallback(const psf: IShellfolder; wnd: HWND; const pdtObj: IDataObject; uMsg: UINT; WParm: WParam; lParm: LParam): HResult; stdcall; procedure AddMenuKey(Key: WideString); {$IFDEF TNTSUPPORT} procedure AddMenuKeys(Keys: TTntStringList); {$ELSE} procedure AddMenuKeys(Keys: TStringList); {$ENDIF} procedure ClearKeys; procedure DoCopy(ShellFolder: IShellFolder; DataObject: IDataObject; var DoDefault: Boolean); virtual; procedure DoCreateShortCut(ShellFolder: IShellFolder; DataObject: IDataObject; var DoDefault: Boolean); virtual; procedure DoCut(ShellFolder: IShellFolder; DataObject: IDataObject; var DoDefault: Boolean); virtual; procedure DoDelete(ShellFolder: IShellFolder; DataObject: IDataObject; var DoDefault: Boolean); virtual; procedure DoHide; virtual; {$IFDEF TNTSUPPORT} procedure DoInvokeCommand(MenuItem: TTntMenuItem; InvokeInfo: PCMInvokeCommandInfo); virtual; {$ELSE} procedure DoInvokeCommand(MenuItem: TMenuItem; InvokeInfo: PCMInvokeCommandInfo); virtual; {$ENDIF} procedure DoMenuMerge(Menu: HMENU; IndexMenu: UINT; var CmdFirst: UINT; CmdLast: UINT; Flags: TShellContextMenuFlags); virtual; procedure DoMenuMergeBottom(Menu: HMENU; IndexMenu: UINT; var CmdFirst: UINT; CmdLast: UINT; Flags: TShellContextMenuFlags); virtual; procedure DoMenuMergeTop(Menu: HMENU; IndexMenu: UINT; var CmdFirst: UINT; CmdLast: UINT; Flags: TShellContextMenuFlags); virtual; procedure DoNewFolder(ShellFolder: IShellFolder; DataObject: IDataObject; var DoDefault: Boolean); virtual; procedure DoPaste(ShellFolder: IShellFolder; DataObject: IDataObject; var DoDefault: Boolean); virtual; procedure DoPasteLink(ShellFolder: IShellFolder; DataObject: IDataObject; var DoDefault: Boolean); virtual; procedure DoPasteShortCut(ShellFolder: IShellFolder; DataObject: IDataObject; var DoDefault: Boolean); virtual; procedure DoProperties(ShellFolder: IShellFolder; DataObject: IDataObject; var DoDefault: Boolean); virtual; procedure DoShow; virtual; function DuplicateKey(Key: HKEY): HKEY; {$IFDEF TNTSUPPORT} function FindCommandId(CmdID: UINT; var MenuItem: TTntMenuItem): Boolean; {$ELSE} function FindCommandId(CmdID: UINT; var MenuItem: TMenuItem): Boolean; {$ENDIF} procedure HandleContextMenuMsg(Msg, wParam, lParam: Longint; var Result: LRESULT); stdcall; function InternalShowContextMenu(Owner: TWinControl; ParentPIDL: PItemIDList; ChildPIDLs: TAbsolutePIDLArray; Verb: WideString; Position: PPoint = nil): Boolean; procedure LoadMultiFolderPIDLArray(Namespaces: TNamespaceArray; var PIDLs: TAbsolutePIDLArray); procedure LoadRegistryKeyStrings(Focused: TNamespace); virtual; abstract; procedure WindowProcForContextMenu(var Message: TMessage); property ActiveFolder: IShellFolder read FActiveFolder write FActiveFolder; property ActivePIDLs: TPIDLArray read FActivePIDLs write FActivePIDLs; property CopyValidated: Boolean read FCopyValidated write FCopyValidated; property CurrentContextMenu2: IContextMenu2 read FCurrentContextMenu2 write FCurrentContextMenu2; property CurrentContextMenu: IContextMenu read FCurrentContextMenu write FCurrentContextMenu; property CutValidated: Boolean read FCutValidated write FCutValidated; property Extensions: TCommonShellContextMenuExtensions read FExtensions write FExtensions; property FromDesktop: Boolean read FFromDesktop write FFromDesktop; {$IFDEF TNTSUPPORT} property KeyStrings: TTntStringList read FKeyStrings write FKeyStrings; {$ELSE} property KeyStrings: TStringList read FKeyStrings write FKeyStrings; {$ENDIF} property LocalFocused: TNamespace read FLocalFocused write FLocalFocused; property LocalNamespaces: TNamespaceArray read FLocalNamespaces write FLocalNamespaces; property MenuMap: TMenuItemMap read FMenuMap write FMenuMap; property OnHide: TCommonShellMenuEvent read FOnHide write FOnHide; property OnInvokeCommand: TCommonShellMenuInvokeEvent read FOnInvokeCommand write FOnInvokeCommand; property OnMenuMerge: TCommonShellMenuMergeEvent read FOnMenuMerge write FOnMenuMerge; property OnMenuMergeBottom: TCommonShellMenuMergeEvent read FOnMenuMergeBottom write FOnMenuMergeBottom; property OnMenuMergeTop: TCommonShellMenuMergeEvent read FOnMenuMergeTop write FOnMenuMergeTop; property OnShellMenuCopy: TCommonShellMenuCopyEvent read FOnShellMenuCopy write FOnShellMenuCopy; property OnShellMenuCreateShortCut: TCommonShellMenuCreateShortcutEvent read FOnShellMenuCreateShortcut write FOnShellMenuCreateShortcut; property OnShellMenuCut: TCommonShellMenuCutEvent read FOnShellMenuCut write FOnShellMenuCut; property OnShellMenuDelete: TCommonShellMenuDeleteEvent read FOnShellMenuDelete write FOnShellMenuDelete; property OnShellMenuNewFolder: TCommonShellMenuNewFolderEvent read FOnShellMenuNewFolder write FOnShellMenuNewFolder; property OnShellMenuPaste: TCommonShellMenuPasteEvent read FOnShellMenuPaste write FOnShellMenuPaste; property OnShellMenuPasteLink: TCommonShellMenuPasteLinkEvent read FOnShellMenuPasteLink write FOnShellMenuPasteLink; property OnShellMenuPasteShortCut: TCommonShellMenuPasteShortCutEvent read FOnShellMenuPasteShortCut write FOnShellMenuPasteShortCut; property OnShellMenuProperites: TCommonShellMenuProperitesEvent read FOnShellMenuProperites write FOnShellMenuProperites; property OnShow: TCommonShellMenuEvent read FOnShow write FOnShow; property Stub: Pointer read FStub write FStub; property RenameMenuItem: Boolean read FRenameMenuItem write FRenameMenuItem default True; property PasteMenuItem: Boolean read FPasteMenuItem write FPasteMenuItem default True; property UIObjectOfDataObject: IDataObject read FUIObjectOfDataObject write FUIObjectOfDataObject; property UIObjectOfDropTarget: IDropTarget read FUIObjectOfDropTarget write FUIObjectOfDropTarget; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; {$IFDEF TNTSUPPORT} function MergeMenuIntoContextMenu(Menu: TTntPopupMenu; ContextMenu: HMenu; Index: Integer; idStart: UINT): Integer; {$ELSE} function MergeMenuIntoContextMenu(Menu: TPopupMenu; ContextMenu: HMenu; Index: Integer; idStart: UINT): Integer; {$ENDIF} procedure ClearMenuMap; end; {*******************************************************************************} { Shell ContextMenu } {*******************************************************************************} TCommonShellBackgroundContextMenu = class(TCommonShellContextMenu) private FAutoDetectNewItem: Boolean; FFinalItemList: TCommonPIDLList; FInitialItemList: TCommonPIDLList; FOnNewItem: TCommonShellMenuNewItemEvent; {$IFDEF TNTSUPPORT} FPaste: TTntMenuItem; FPasteShortCut: TTntMenuItem; FPopupMenuProperties: TTntPopupMenu; FPopupMenuPaste: TTntPopupMenu; FPopupMenuPasteShortCut: TTntPopupMenu; FProperties: TTntMenuItem; {$ELSE} FPaste: TMenuItem; FPasteShortCut: TMenuItem; FPopupMenuProperties: TPopupMenu; FPopupMenuPaste: TPopupMenu; FPopupMenuPasteShortCut: TPopupMenu; FProperties: TMenuItem; {$ENDIF} FShowPasteItem: Boolean; FShowPasteShortCutItem: Boolean; FShowPropertiesItem: Boolean; protected procedure ClickPaste(Sender: TObject); procedure ClickPasteShortCut(Sender: TObject); procedure ClickProperties(Sender: TObject); procedure DoHide; override; procedure DoMenuMerge(Menu: HMENU; IndexMenu: UINT; var CmdFirst: UINT; CmdLast: UINT; Flags: TShellContextMenuFlags); override; procedure DoMenuMergeBottom(Menu: HMENU; IndexMenu: UINT; var CmdFirst: UINT; CmdLast: UINT; Flags: TShellContextMenuFlags); override; procedure DoMenuMergeTop(Menu: HMENU; IndexMenu: UINT; var CmdFirst: UINT; CmdLast: UINT; Flags: TShellContextMenuFlags); override; procedure DoNewItem(NS: TNamespace); virtual; procedure DoShow; override; procedure LoadRegistryKeyStrings(Focused: TNamespace); override; property FinalItemList: TCommonPIDLList read FFinalItemList write FFinalItemList; property InitialItemList: TCommonPIDLList read FInitialItemList write FInitialItemList; {$IFDEF TNTSUPPORT} property Paste: TTntMenuItem read FPaste write FPaste; property PasteShortCut: TTntMenuItem read FPasteShortCut write FPasteShortCut; property PopupMenuProperties: TTntPopupMenu read FPopupMenuProperties write FPopupMenuProperties; property PopupMenuPaste: TTntPopupMenu read FPopupMenuPaste write FPopupMenuPaste; property PopupMenuPasteShortCut: TTntPopupMenu read FPopupMenuPasteShortCut write FPopupMenuPasteShortCut; property Properties: TTntMenuItem read FProperties write FProperties; {$ELSE} property Paste: TMenuItem read FPaste write FPaste; property PasteShortCut: TMenuItem read FPasteShortCut write FPasteShortCut; property PopupMenuProperties: TPopupMenu read FPopupMenuProperties write FPopupMenuProperties; property PopupMenuPaste: TPopupMenu read FPopupMenuPaste write FPopupMenuPaste; property PopupMenuPasteShortCut: TPopupMenu read FPopupMenuPasteShortCut write FPopupMenuPasteShortCut; property Properties: TMenuItem read FProperties write FProperties; {$ENDIF} property RenameMenuItem default False; property PasteMenuItem default False; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function EnumCallback(MessageWnd: HWnd; APIDL: PItemIDList; AParent: TNamespace; Data: Pointer; var Terminate: Boolean): Boolean; function ShowContextMenu(Owner: TWinControl; Root: TNamespace; Position: PPoint = nil): Boolean; virtual; published property AutoDetectNewItem: Boolean read FAutoDetectNewItem write FAutoDetectNewItem; property OnHide; property OnInvokeCommand; property OnMenuMerge; property OnMenuMergeBottom; property OnMenuMergeTop; property OnNewItem: TCommonShellMenuNewItemEvent read FOnNewItem write FOnNewItem; property OnShow; property ShowPasteItem: Boolean read FShowPasteItem write FShowPasteItem default True; property ShowPasteShortCutItem: Boolean read FShowPasteShortCutItem write FShowPasteShortCutItem default True; property ShowPropertiesItem: Boolean read FShowPropertiesItem write FShowPropertiesItem default True; end; TCommonShellMultiParentContextMenu = class(TCommonShellContextMenu) protected procedure LoadRegistryKeyStrings(Focused: TNamespace); override; public function ExecuteContextMenuVerb(Owner: TWinControl; Namespaces: TNamespaceArray; Verb: string): Boolean; virtual; function ShowContextMenu(Owner: TWinControl; Focused: TNamespace; Namespaces: TNamespaceArray; Position: PPoint = nil): Boolean; virtual; published property OnHide; property OnShellMenuCopy; property OnShellMenuCreateShortCut; property OnShellMenuCut; property OnShellMenuDelete; property OnShellMenuNewFolder; property OnShellMenuPaste; property OnShellMenuPasteLink; property OnShellMenuPasteShortCut; property OnShellMenuProperites; property RenameMenuItem; property PasteMenuItem; property OnShow; end; {-------------------------------------------------------------------------------} { Exported Functions } {-------------------------------------------------------------------------------} // Rectange Functions function RectWidth(ARect: TRect): integer; function RectHeight(ARect: TRect): integer; // PIDL Functions function FindBrowseableRootPIDL(NS: TNamespace): PItemIDList; function IsParentBrowseable(NS: TNamespace): Boolean; function NamespaceToAbsolutePIDLArray(Namespaces: TNamespaceArray): TAbsolutePIDLArray; function NamespaceToRelativePIDLArray(Namespaces: TNamespaceArray): TRelativePIDLArray; function PathToPIDL(APath: WideString): PItemIDList; function PIDLToPath(APIDL: PItemIDList): WideString; function DirExistsVET(APath: WideString; ShowSystemMessages: Boolean): Boolean; overload; function DirExistsVET(NS: TNamespace; ShowSystemMessages: Boolean): Boolean; overload; procedure PIDLListQuickSort(PIDLList: TCommonPIDLList; const ParentFolder: IShellFolder; L, R: Integer); procedure PIDLQuickSort(PIDLList: TPIDLArray; const ParentFolder: IShellFolder; L, R: Integer); // Time Conversions //** NOTE these are not WideString functions they will use ANSI strings internally function ConvertLocalStrToTFileTime(LocalStr: WideString; var FileTime: TFileTime): Boolean; function ConvertTFileTimeToLocalStr(AFileTime: TFILETIME): WideString; function ConvertFileTimetoDateTime(AFileTime : TFileTime): TDateTime; // Various Functions function CreateSpecialNamespace(FolderID: integer): TNamespace; function DefaultSystemImageIndex(FolderType: TDefaultFolderIcon): integer; function FileIconInit(FullInit: BOOL): BOOL; stdcall; function IENamespaceShown(PerUser: Boolean): Boolean; function GUIDToInterfaceStr(riid: TGUID): String; function CFM_FlagsToShellContextMenuFlags(Flags: DWORD): TShellContextMenuFlags; function ClipboardContainsShellFormats: Boolean; // IShellLink (ShortCut) helpers function CreateShellLink( ALnkFilePath, ATargetFilePath: WideString; AnArguments: WideString = ''; AWorkingDir: WideString = ''; ADescription: WideString = ''; AShowCmd: TCmdShow = swShowNormal; AHotKey: Word = 0; AHotKeyModifier: THotKeyModifiers = []; AnIconLocation: WideString = ''; AnIconIndex: integer = 0 ): Boolean; function HotKeyModifiersToStr(HotKeyMod: THotKeyModifiers): WideString; function PotentialMappedDrive(NS: TNamespace): Boolean; function FileObjectsToFlags(FileObjects: TFileObjects): DWORD; function FileObjectsToString(FileObjects: TFileObjects): WideString; {$ifdef COMPILER_4} procedure FreeAndNil(var Obj); function Supports(const Instance: IUnknown; const Intf: TGUID; out Inst): Boolean; {$endif} function GetDiskFreeSpaceMP(Drive: PWideChar; var SectorsperCluster, BytesperSector, FreeClusters, TotalClusters: DWORD): boolean; function DriveSize(Drive: PWideChar): Int64; overload; function DriveSize(Drive: PWideChar; ByteSize: TBtyeSize): WideString; overload; function DriveFreeSpace(Drive: PWideChar): Int64; overload; function DriveFreeSpace(Drive: PWideChar; ByteSize: TBtyeSize): WideString; overload; function IsSpecialVariable(TestPath: WideString; var NS: TNamespace): Boolean; function SpecialVariableReplacePath(var Path: WideString): Boolean; // function MPBrowseForFolder(Title, InitialPath: WideString; BrowseFlags: TMPBrowseFlags): WideString; overload; function MPBrowseForFolder(Title, RootFolder, InitialPath: WideString; BrowseFlags: TMPBrowseFlags; var SelectedPath: WideString): Boolean; overload; function MPBrowseForFolder(Title: WideString; RootFolder, InitialPath: PItemIDList; BrowseFlags: TMPBrowseFlags; var SelectedPath: PItemIDList): Boolean; overload; // Merges a TVirtualShellPopupMenu object into a Shell Context Menu {$IFDEF TNTSUPPORT} function MergeMenuIntoContextMenu(Menu: TTntPopupMenu; ContextMenu: HMenu; Index: Integer; idStart: UINT): Integer; {$ELSE} function MergeMenuIntoContextMenu(Menu: TPopupMenu; ContextMenu: HMenu; Index: Integer; idStart: UINT): Integer; {$ENDIF} var { A few global common Namespaces to be used for various purposes. } PIDLMgr: TCommonPIDLManager; DesktopFolder, RecycleBinFolder, PhysicalDesktopFolder, DrivesFolder, HistoryFolder, PrinterFolder, ControlPanelFolder, NetworkNeighborHoodFolder, TemplatesFolder, MyDocumentsFolder, FavoritesFolder, ProgramFilesFolder, UserDocumentsFolder: TNamespace; SHLimitInputEdit: TSHLimitInputEdit; AnimateWindow: function(Wnd: HWND; dwTime: Cardinal; dwFlags: Cardinal): WordBool; stdcall; // Fundamental Change in Version 2.0. Should be more correct in what shell dialogs // are Modal and if they stay on top of the correct window. MP_UseModalDialogs: Boolean = True; // Causes calls to GetUIIObject to use a parent window MP_UseSpecialReparsePointOverlay: Boolean = False; // Shows an overlay on Reparse points MP_ThreadedShellExecute: Boolean = False; // Causes shell Execute to be launched in a separate thread implementation uses Dialogs; type TShellILIsParent = function(PIDL1: PItemIDList; PIDL2: PItemIDList; ImmediateParent: LongBool): LongBool; stdcall; TShellILIsEqual = function(PIDL1: PItemIDList; PIDL2: PItemIDList): LongBool; stdcall; var ShellILIsParent: TShellILIsParent; ShellILIsEqual: TShellILIsEqual; //////////////////////////////////////////////////////////////////////////////// // Global Functions //////////////////////////////////////////////////////////////////////////////// function SpecialVariableReplacePath(var Path: WideString): Boolean; function ReplacePath(Path, Variable, VarPath: WideString): WideString; begin Result := WideStringReplace(Path, Variable, VarPath, [rfReplaceAll, rfIgnoreCase]); end; var OldPath: WideString; begin OldPath := Path; // Psudo Variables Path := ReplacePath(Path, '%sysdir%', WideLowerCase(WideStripTrailingBackslash(SystemDirectory))); Path := ReplacePath(Path, '%temp%', WideLowerCase(WideStripTrailingBackslash(WideGetTempDir))); Path := ReplacePath(Path, '%appdata%', WideLowerCase(WideStripTrailingBackslash(UserDocumentsFolder.NameForParsing))); Path := ReplacePath(Path, '%favorites%', WideLowerCase(WideStripTrailingBackslash(FavoritesFolder.NameForParsing))); Path := ReplacePath(Path, '%personal%', WideLowerCase(WideStripTrailingBackslash(MyDocumentsFolder.NameForParsing))); Path := ReplacePath(Path, '%templates%', WideLowerCase(WideStripTrailingBackslash(TemplatesFolder.NameForParsing))); Path := ReplacePath(Path, '%history%', WideLowerCase(WideStripTrailingBackslash(HistoryFolder.NameForParsing))); Path := ReplacePath(Path, '%desktopfolder%', WideLowerCase(WideStripTrailingBackslash(PhysicalDesktopFolder.NameForParsing))); // Environment variables Path := ReplacePath(Path, '%userprofile%', WideStripTrailingBackslash(WideExpandEnviromentString('%USERPROFILE%'))); Path := ReplacePath(Path, '%allusersprofile%', WideStripTrailingBackslash(WideExpandEnviromentString('%ALLUSERSPROFILE%'))); Path := ReplacePath(Path, '%programfiles%', WideStripTrailingBackslash(WideExpandEnviromentString('%ProgramFiles%'))); Path := ReplacePath(Path, '%systemroot%', WideStripTrailingBackslash(WideExpandEnviromentString('%SystemRoot%'))); Path := ReplacePath(Path, '%systemdrive%', WideStripTrailingBackslash(WideExpandEnviromentString('%SystemDrive%'))); Path := ReplacePath(Path, '%windir%', WideStripTrailingBackslash(WideExpandEnviromentString('%windir%'))); Path := ReplacePath(Path, '%tmp%', WideStripTrailingBackslash(WideExpandEnviromentString('%TMP%'))); Path := ReplacePath(Path, '%temp%', WideStripTrailingBackslash(WideExpandEnviromentString('%TEMP%'))); Path := ReplacePath(Path, '%public%', WideStripTrailingBackslash(WideExpandEnviromentString('%PUBLIC%'))); Path := ReplacePath(Path, '%programdata%', WideStripTrailingBackslash(WideExpandEnviromentString('%ProgramData%'))); Path := ReplacePath(Path, '%homedrive%', WideStripTrailingBackslash(WideExpandEnviromentString('%HOMEDRIVE%'))); Path := ReplacePath(Path, '%homepath%', WideStripTrailingBackslash(WideExpandEnviromentString('%HOMEPATH%'))); Path := ReplacePath(Path, '%commonprogramfiles%', WideStripTrailingBackslash(WideExpandEnviromentString('%CommonProgramFiles%'))); Path := ReplacePath(Path, '%appdata%', WideStripTrailingBackslash(WideExpandEnviromentString('%APPDATA%'))); Result := OldPath <> Path end; function IsSpecialVariable(TestPath: WideString; var NS: TNamespace): Boolean; var PIDL: PItemIDList; begin NS := nil; PIDL := nil; if WideLowerCase(TestPath) = '%desktop%' then PIDL := PIDLMgr.CopyPIDL(DesktopFolder.AbsolutePIDL) else if WideLowerCase(TestPath) = '%network%' then PIDL := PIDLMgr.CopyPIDL(NetworkNeighborHoodFolder.AbsolutePIDL) else if WideLowerCase(TestPath) = '%printer%' then PIDL := PIDLMgr.CopyPIDL(PrinterFolder.AbsolutePIDL) else if (WideLowerCase(TestPath) = '%drives%') or (WideLowerCase(TestPath) = '%mycomputer%') then PIDL := PIDLMgr.CopyPIDL(DrivesFolder.AbsolutePIDL) else begin if SpecialVariableReplacePath(TestPath) then if WideDirectoryExists(TestPath) then PIDL := PathToPIDL(TestPath) end; if Assigned(PIDL) then NS := TNamespace.Create(PIDL, nil) else if not Assigned(NS) and not WideDirectoryExists(TestPath) then begin // See if it a specially formated CLSID PIDL := PathToPIDL(TestPath); if Assigned(PIDL) then NS := TNamespace.Create(PIDL, nil); end; Result := Assigned(NS) end; function GUIDToInterfaceStr(riid: TGUID): String; begin if IsEqualGUID(riid, IOleCommandTarget) then Result := 'IOleCommandTarget' else if IsEqualGUID(riid, IID_IPersistFreeThreadedObject) then Result := 'IPersistFreeThreadedObject' else if IsEqualGUID(riid, IShellView) then Result := 'IShellView' else if IsEqualGUID(riid, IID_ICategoryProvider) then Result := 'ICategoryProvider' else if IsEqualGUID(riid, IID_IQueryAssociations) then Result := 'IQueryAssociations' else if IsEqualGUID(riid, IID_IAssociationArray) then Result := 'IAssociationArray' else if IsEqualGUID(riid, IPersistIDList) then Result := 'IPersistIDList' else if IsEqualGUID(riid, IID_IInternetSecurityManager) then Result := 'IInternetSecurityManager' else if IsEqualGUID(riid, IObjectWithSite) then Result := 'IObjectWithSite' else if IsEqualGUID(riid, IPersist) then Result := 'IPersist' else if IsEqualGUID(riid, IPersistFolder) then Result := 'IPersistFolder' else if IsEqualGUID(riid, IPersistFolder2) then Result := 'IPersistFolder2' else if IsEqualGUID(riid, IShellFolder) then Result := 'IShellFolder' else if IsEqualGUID(riid, IShellFolder2) then Result := 'IShellFolder2' else if IsEqualGUID(riid, IShellFolderViewCB) then Result := 'IShellFolderViewCB' else if IsEqualGUID(riid, IContextMenu) then Result := 'IContextMenu' else if IsEqualGUID(riid, IContextMenu2) then Result := 'IContextMenu2' else if IsEqualGUID(riid, IContextMenu3) then Result := 'IContextMenu3' (* else {$IFDEF CPPB_6_UP} if IsEqualGUID(riid, IBCB6ShellDetails) then {$ELSE} if IsEqualGUID(riid, IShellDetails) then {$ENDIF} Result := 'IShellDetails' *) else if IsEqualGUID(riid, IStream) then Result := 'IStream' else if IsEqualGUID(riid, IDataObject) then Result := 'IDataObject' else if IsEqualGUID(riid, IDropSource) then Result := 'IDropSource' else if IsEqualGUID(riid, IDropTarget) then Result := 'IDropTarget' else if IsEqualGUID(riid, IExtractIconA) then Result := 'IExtractIconA' else if IsEqualGUID(riid, IExtractIconW) then Result := 'IExtractIconW' else if IsEqualGUID(riid, IExtractImage) then Result := 'IExtractImage' else if IsEqualGUID(riid, IQueryInfo) then Result := 'IQueryInfo' else if IsEqualGUID(riid, IShellIcon) then Result := 'IShellIcon' else if IsEqualGUID(riid, IBrowserFrameOptions) then Result := 'IBrowserFrameOptions' else if IsEqualGUID(riid, IBindHost) then Result := 'IBindHost' else if IsEqualGUID(riid, IID_IBindProtocol) then Result := 'IBindProtocol' else if IsEqualGUID(riid, IClassFactory) then Result := 'IClassFactory' else if IsEqualGUID(riid, IShellExtInit) then Result := 'IShellExtInit' else if IsEqualGUID(riid, IShellLinkW) then Result := 'IShellLinkW' else if IsEqualGUID(riid, IShellLinkA) then Result := 'IShellLinkW' else Result := 'Unknown GUID: ' + GUIDToString(riid) end; function CFM_FlagsToShellContextMenuFlags(Flags: DWORD): TShellContextMenuFlags; begin Result := []; if CMF_CANRENAME and Flags <> 0 then Include(Result, cmfCanRename); if CMF_CANRENAME and Flags <> 0 then Include(Result, cmfCanRename); // if CMF_DISABLEVERBS and Flags <> 0 then // Include(Result, cmfDisableVerbs); if CMF_EXPLORE and Flags <> 0 then Include(Result, cmfExplore); if CMF_INCLUDESTATIC and Flags <> 0 then Include(Result, cmfIncludeStatic); if CMF_NODEFAULT and Flags <> 0 then Include(Result, cmfNoDefault); if CMF_NORMAL and Flags <> 0 then Include(Result, cmfNormal); if CMF_NOVERBS and Flags <> 0 then Include(Result, cmfNoVerbs); if CMF_VERBSONLY and Flags <> 0 then Include(Result, cmfVerbsOnly); end; function ClipboardContainsShellFormats: Boolean; begin Result := IsClipboardFormatAvailable(CF_SHELLIDLIST) or IsClipboardFormatAvailable(CF_HDROP) end; function MPBrowseForFolderCallback(Wnd: hWnd; uMsg: UINT; lParam: LPARAM; lpData: LPARAM): Integer; stdcall; begin case uMsg of BFFM_INITIALIZED: begin // This is the PIDL of the starting folder if lpData <> 0 then SendMessage(Wnd, BFFM_SETSELECTION, 0, lpData); end; BFFM_SELCHANGED: begin end; BFFM_VALIDATEFAILEDA: begin end; BFFM_VALIDATEFAILEDW: begin end; end; Result := 0; end; function MPBrowseForFolder(Title: WideString; RootFolder, InitialPath: PItemIDList; BrowseFlags: TMPBrowseFlags; var SelectedPath: PItemIDList): Boolean; function FlagsToTMPBrowseFlags(Flags: TMPBrowseFlags): DWORD; begin Result := 0; if mpbfComputers in Flags then Result := Result or BIF_BROWSEFORCOMPUTER; if mpbfPrinters in Flags then Result := Result or BIF_BROWSEFORPRINTER; if mpbfDontGoBelowDomain in Flags then Result := Result or BIF_DONTGOBELOWDOMAIN; if mpbfFileSysAncestors in Flags then Result := Result or BIF_RETURNFSANCESTORS; if mpbfFileSysFolder in Flags then Result := Result or BIF_RETURNONLYFSDIRS; // if mpbfIncludeStatusText in Flags then // Result := Result or BIF_STATUSTEXT; if mpbfIncludeFiles in Flags then Result := Result or BIF_BROWSEINCLUDEFILES; if mpbfNewStyleDialog in Flags then Result := Result or BIF_NEWDIALOGSTYLE; if mpbfEditBox in Flags then Result := Result or BIF_EDITBOX; if mpbfIncludeURLs in Flags then Result := Result or BIF_BROWSEINCLUDEURLS; if mpbfSharable in Flags then Result := Result or BIF_SHAREABLE; if mpbfMustExist in Flags then Result := Result or BIF_VALIDATE; end; var BrowseInfoW: TBrowseInfoW; BrowseInfoA: TBrowseInfoA; DisplayNameA: array [0..MAX_PATH] of Char; DisplayNameW: array [0..MAX_PATH] of WideChar; begin if IsUnicode then begin FillChar(BrowseInfoW, SizeOf(BrowseInfoW), #0); BrowseInfoW.hwndOwner := GetActiveWindow; BrowseInfoW.pidlRoot := RootFolder; BrowseInfoW.lParam := Integer( InitialPath); BrowseInfoW.pszDisplayName := DisplayNameW; {$IFDEF CPPB} BrowseInfoW.lpfn := MPBrowseForFolderCallback; {$ELSE} BrowseInfoW.lpfn := @MPBrowseForFolderCallback; {$ENDIF} BrowseInfoW.lpszTitle := PWideChar(Title); BrowseInfoW.ulFlags := FlagsToTMPBrowseFlags(BrowseFlags); SelectedPath := SHBrowseForFolderW_MP(BrowseInfoW); end else begin FillChar(BrowseInfoA, SizeOf(BrowseInfoA), #0); BrowseInfoA.hwndOwner := GetActiveWindow; BrowseInfoW.pidlRoot := RootFolder; BrowseInfoA.lParam := Integer( InitialPath); BrowseInfoA.pszDisplayName := DisplayNameA; {$IFDEF CPPB} BrowseInfoA.lpfn := MPBrowseForFolderCallback; {$ELSE} BrowseInfoA.lpfn := @MPBrowseForFolderCallback; {$ENDIF} BrowseInfoA.lpszTitle := PChar(string(Title)); BrowseInfoA.ulFlags := FlagsToTMPBrowseFlags(BrowseFlags); SelectedPath := SHBrowseForFolderA(BrowseInfoA); end; Result := Assigned(SelectedPath) end; function MPBrowseForFolder(Title, RootFolder, InitialPath: WideString; BrowseFlags: TMPBrowseFlags; var SelectedPath: WideString): Boolean; overload; var NS: TNamespace; RootPIDL, InitialPathPIDL, ReturnPIDL: PItemIDList; begin RootPIDL := PathToPIDL(RootFolder); InitialPathPIDL := PathToPIDL(InitialPath); ReturnPIDL := nil; Result := MPBrowseForFolder(Title, RootPIDL, InitialPathPIDL, BrowseFlags, ReturnPIDL); if Result then begin NS := TNamespace.Create(ReturnPIDL, nil); SelectedPath := NS.NameParseAddress; NS.Free; end; PIDLMgr.FreePIDL(RootPIDL); PIDLMgr.FreePIDL(InitialPathPIDL); end; {$IFDEF TNTSUPPORT} function MergeMenuIntoContextMenu(Menu: TTntPopupMenu; ContextMenu: HMenu; Index: Integer; idStart: UINT): Integer; var i: Integer; begin Result := -1; if Assigned(Menu) and (ContextMenu <> 0) then begin Result := idStart; for i := Menu.Items.Count - 1 downto 0 do begin AddContextMenuItem(ContextMenu, Menu.Items[i].Caption, Index, Result); Inc(Result); if Menu.Items[i].Count > 0 then beep; end end end; {$ELSE} function MergeMenuIntoContextMenu(Menu: TPopupMenu; ContextMenu: HMenu; Index: Integer; idStart: UINT): Integer; var i: Integer; begin Result := -1; if Assigned(Menu) and (ContextMenu <> 0) then begin Result := idStart; for i := Menu.Items.Count - 1 downto 0 do begin AddContextMenuItem(ContextMenu, Menu.Items[i].Caption, Index, Result); Inc(Result); if Menu.Items[i].Count > 0 then beep; end end end; {$ENDIF} // PIDL Functions { ----------------------------------------------------------------------------- } function NamespaceToRelativePIDLArray(Namespaces: TNamespaceArray): TRelativePIDLArray; var i: integer; begin Result := nil; if Assigned(Namespaces) then begin SetLength(Result, Length(Namespaces)); for i := 0 to Length(Namespaces) - 1 do Result[i] := Namespaces[i].RelativePIDL; end end; function FindBrowseableRootPIDL(NS: TNamespace): PItemIDList; var Found: Boolean; begin Result := nil; Found := False; if Assigned(NS) then begin if not NS.Folder then NS := NS.Parent; if IsParentBrowseable(NS) then begin while not Found and not NS.IsDesktop do begin if NS.Browsable then Found := True else NS := NS.Parent end end; Result := PIDLMgr.CopyPIDL(NS.AbsolutePIDL) end end; function IsParentBrowseable(NS: TNamespace): Boolean; begin Result := False; if Assigned(NS) then begin while not Result and not NS.IsDesktop do begin Result := NS.Browsable; if not Result then NS := NS.Parent end end end; function NamespaceToAbsolutePIDLArray(Namespaces: TNamespaceArray): TAbsolutePIDLArray; var i: integer; begin Result := nil; if Assigned(Namespaces) then begin SetLength(Result, Length(Namespaces)); for i := 0 to Length(Namespaces) - 1 do Result[i] := Namespaces[i].AbsolutePIDL; end end; { ----------------------------------------------------------------------------- } function PathToPIDL(APath: WideString): PItemIDList; // Takes the passed Path and attempts to convert it to the equavalent PIDL var Desktop: IShellFolder; pchEaten, dwAttributes: ULONG; begin Result := nil; begin SHGetDesktopFolder(Desktop); dwAttributes := 0; if Assigned(Desktop) then Desktop.ParseDisplayName(0, nil, PWideChar(APath), pchEaten, Result, dwAttributes) end end; { ----------------------------------------------------------------------------- } { ----------------------------------------------------------------------------- } function PIDLToPath(APIDL: PItemIDList): WideString; var Folder: TNamespace; begin Result := ''; Folder := TNamespace.Create(APIDL, nil); try Folder.FreePIDLOnDestroy := False; if Assigned(Folder) then Result := Folder.NameForParsing; finally Folder.Free end end; { ----------------------------------------------------------------------------- } function IENamespaceShown(PerUser: Boolean): Boolean; var Reg: TRegistry; begin Result := True; Reg := TRegistry.Create; try if PerUser then Reg.RootKey := HKEY_CURRENT_USER else Reg.RootKey := HKEY_LOCAL_MACHINE; if Reg.KeyExists('Software\Microsoft\Windows\CurrentVersion\Explorer\HideDesktopIcons\NewStartPanel') then begin if Reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\HideDesktopIcons\NewStartPanel', False) then begin if Reg.ValueExists('{871C5380-42A0-1069-A2EA-08002B30309D}') then begin Result := Reg.ReadInteger('{871C5380-42A0-1069-A2EA-08002B30309D}') = 0; end end end; finally Reg.Free end; end; { ----------------------------------------------------------------------------- } function DirExistsVET(APath: WideString; ShowSystemMessages: Boolean): Boolean; overload; const FLAGS = SHCONTF_FOLDERS or SHCONTF_NONFOLDERS or SHCONTF_INCLUDEHIDDEN; var Desktop, Folder: IShellFolder; TempPIDL, PIDL: PItemIDList; EnumIDList: IEnumIDList; hWndOwner: THandle; TempPath: WideString; begin Result := False; PIDL := nil; if ShowSystemMessages then hWndOwner := GetActiveWindow //Application.Handle else hWndOwner := 0; TempPath := WideExtractFileDrive(APath) + '\'; // First make sure the drive is available, it may be a remoted password protected drive TempPIDL := PathToPIDL(TempPath); if Succeeded(SHGetDesktopFolder(Desktop)) then if Succeeded(Desktop.BindToObject(TempPIDL, nil, IShellFolder, Pointer(Folder))) then if Folder.EnumObjects(hWndOwner, FLAGS, EnumIDList)= NOERROR then begin PIDL := PathToPIDL(APath); if Succeeded(Desktop.BindToObject(PIDL, nil, IShellFolder, Pointer(Folder))) then Result := Folder.EnumObjects(hWndOwner, FLAGS, EnumIDList)= NOERROR end; coTaskMemFree(TempPIDL); if Assigned(PIDL) then coTaskMemFree(PIDL); end; { ----------------------------------------------------------------------------- } { ----------------------------------------------------------------------------- } function DirExistsVET(NS: TNamespace; ShowSystemMessages: Boolean): Boolean; overload; begin Result := DirExistsVET(NS.NameForParsing, ShowSystemMessages) end; { ----------------------------------------------------------------------------- } function RectWidth(ARect: TRect): integer; begin Result := ARect.Right - ARect.Left end; { ----------------------------------------------------------------------------- } { ----------------------------------------------------------------------------- } function RectHeight(ARect: TRect): integer; begin Result := ARect.Bottom - ARect.Top end; { ----------------------------------------------------------------------------- } function PotentialMappedDrive(NS: TNamespace): Boolean; // A mapped drive will not return valid information, other then // its display name under some conditions so always try it. var DriveType: DWORD; begin Result := False; if WideIsDrive(NS.NameForParsing) then begin if Assigned(GetDriveTypeW_MP) then DriveType := GetDriveTypeW_MP(PWideChar(NS.NameForParsing)) else DriveType := GetDriveType(PChar(string(NS.NameForParsing))); Result := (DriveType = DRIVE_NO_ROOT_DIR) or (DriveType = DRIVE_REMOTE) end end; { ----------------------------------------------------------------------------- } function FileObjectsToFlags(FileObjects: TFileObjects): DWORD; begin Result := 0; if foFolders in FileObjects then Result := Result or SHCONTF_FOLDERS; if foNonFolders in FileObjects then Result := Result or SHCONTF_NONFOLDERS; if foHidden in FileObjects then Result := Result or SHCONTF_INCLUDEHIDDEN; if IsUnicode and not IsWinNT4 then begin if foShareable in FileObjects then Result := Result or SHCONTF_SHAREABLE; if foNetworkPrinters in FileObjects then Result := Result or SHCONTF_NETPRINTERSRCH; end; end; function FileObjectsToString(FileObjects: TFileObjects): WideString; begin Result := ''; if foFolders in FileObjects then Result := Result + 'Folders, '; if foNonFolders in FileObjects then Result := Result + 'NonFolders, '; if foHidden in FileObjects then Result := Result + 'Hidden, '; if foShareable in FileObjects then Result := Result + 'Shareable, '; if foNetworkPrinters in FileObjects then Result := Result + 'NetworkPrinters, '; if Length(Result) > 0 then SetLength(Result, Length(Result) - 2) end; // Time Conversions { ----------------------------------------------------------------------------- } // ANSI function ConvertLocalStrToTFileTime(LocalStr: WideString; var FileTime: TFileTime): Boolean; var SystemTime: TSystemTime; begin Result := True; try DateTimeToSystemTime(StrToDateTime(LocalStr), SystemTime) except on EConvertError do Result := False; end; if Result then Result := SystemTimeToFileTime(SystemTime, FileTime); end; { ----------------------------------------------------------------------------- } function ValidFileTime(FileTime: TFileTime): Boolean; begin Result := (FileTime.dwLowDateTime <> 0) or (FileTime.dwHighDateTime <> 0); end; { ----------------------------------------------------------------------------- } // Converts a TFileTime structure into a local Time/Date String. This requires // a check to make sure the TFileTime structure contains some info through // the local function ValidFileTime then trying to convert the UTC time to Local // UTC time. Then finally changing the UTC time to System time. // ANSI/ function ConvertTFileTimeToLocalStr(AFileTime: TFILETIME): WideString; var SysTime: TSystemTime; LocalFileTime: TFILETIME; begin if ValidFileTime(AFileTime) and FileTimeToLocalFileTime(AFileTime, LocalFileTime) and FileTimeToSystemTime(LocalFileTime, SysTime) then try Result := DateTimeToStr(SystemTimeToDateTime(SysTime)) except Result := ''; end else Result := ''; end; { ----------------------------------------------------------------------------- } function ConvertFileTimetoDateTime(AFileTime : TFileTime): TDateTime; var SysTime: TSystemTime; LocalFileTime: TFILETIME; begin if ValidFileTime(AFileTime) and FileTimeToLocalFileTime(AFileTime, LocalFileTime) and FileTimeToSystemTime(LocalFileTime, SysTime) then try Result := SystemTimeToDateTime(SysTime); except Result := 0; end else Result := 0; end; // Various Functions { ----------------------------------------------------------------------------- } function CreateSpecialNamespace(FolderID: integer): TNamespace; { Creates a TNamespace based on the SpecialFolders defined by } { SHGetSpecialFolderLocation. } var PIDL: PItemIDList; F: IShellFolder; begin SHGetspecialFolderLocation(0, FolderID, PIDL); if Assigned(PIDL) then begin Result := TNamespace.Create(PIDL, nil); F := Result.ParentShellFolder // just force the namespace to have Parent end else Result := nil end; { ----------------------------------------------------------------------------- } { ----------------------------------------------------------------------------- } function DefaultSystemImageIndex(FolderType: TDefaultFolderIcon): integer; { Extracts the default Icon for the given folder type passed to it. } var FileInfoA: TSHFileInfo; FileInfoW: TSHFileInfoW; FileExampleW: WideString; FileExampleA: string; Attrib, Flags: DWORD; PIDL: PItemIDList; NS: TNamespace; begin Result := -1; Attrib := 0; Flags := 0; case FolderType of diNormalFolder: begin FileExampleW := '*.*'; Attrib := FILE_ATTRIBUTE_DIRECTORY; Flags := SHGFI_USEFILEATTRIBUTES or SHGFI_SHELLICONSIZE or SHGFI_SYSICONINDEX end; diOpenFolder: begin FileExampleW := '*.*'; Attrib := FILE_ATTRIBUTE_DIRECTORY; Flags := SHGFI_USEFILEATTRIBUTES or SHGFI_SHELLICONSIZE or SHGFI_SYSICONINDEX or SHGFI_OPENICON end; diUnknownFile: begin FileExampleW := '*.zyxwv'; Attrib := FILE_ATTRIBUTE_NORMAL; Flags := SHGFI_USEFILEATTRIBUTES or SHGFI_SHELLICONSIZE or SHGFI_SYSICONINDEX end; diLink: begin FileExampleW := ''; Result := SHORTCUT_ICON_INDEX; end; diMyDocuments: begin if Assigned(DesktopFolder) then begin PIDL := DesktopFolder.ParseDisplayName('::{450d8fba-ad25-11d0-98a8-0800361b1103}'); if Assigned(PIDL) then begin NS := TNamespace.Create(PIDL, nil); Result := NS.GetIconIndex(False, icSmall, True); NS.Free end end else Result := DefaultSystemImageIndex(diNormalFolder) end else FileExampleW := '' end; if FileExampleW <> '' then begin if IsUnicode then begin FillChar(FileInfoW, SizeOf(FileInfoW), #0); SHGetFileInfoW_MP(PWideChar(FileExampleW), Attrib, FileInfoW, SizeOf(TSHFileInfoW), Flags); Result := FileInfoW.iIcon; end else begin FileExampleA := FileExampleW; FillChar(FileInfoA, SizeOf(FileInfoA), #0); SHGetFileInfoA(PChar(FileExampleA), Attrib, FileInfoA, SizeOf(TSHFileInfoA), Flags); Result := FileInfoA.iIcon; end end end; { ----------------------------------------------------------------------------- } { ----------------------------------------------------------------------------- } // Forces the correct icons for the Common Program Groups on Windows NT 4.0. // Borrowed from John T and GXExplorer function FileIconInit(FullInit: BOOL): BOOL; stdcall; type TFileIconInit = function(FullInit: BOOL): BOOL; stdcall; var ShellDLL: HMODULE; PFileIconInit: TFileIconInit; begin Result := False; if (Win32Platform = VER_PLATFORM_WIN32_NT) then begin ShellDLL := GetModuleHandle(PChar(Shell32)); // ShellDLL := LoadLibrary(PChar(Shell32)); PFileIconInit := GetProcAddress(ShellDLL, PChar(660)); if (Assigned(PFileIconInit)) then Result := PFileIconInit(FullInit); end; end; { ----------------------------------------------------------------------------- } // IShellLink (ShortCut) helpers { ----------------------------------------------------------------------------- } function CreateShellLink(ALnkFilePath, ATargetFilePath: WideString; AnArguments: WideString = ''; AWorkingDir: WideString = ''; ADescription: WideString = ''; AShowCmd: TCmdShow = swShowNormal; AHotKey: Word = 0; AHotKeyModifier: THotKeyModifiers = []; AnIconLocation: WideString = ''; AnIconIndex: integer = 0): Boolean; var ShellLink: TVirtualShellLink; begin Result := True; ShellLink := TVirtualShellLink.Create(nil); if Assigned(ShellLink) then try try ShellLink.FileName := ALnkFilePath; ShellLink.TargetPath := ATargetFilePath; if AnArguments <> '' then ShellLink.Arguments := AnArguments; if AWorkingDir <> '' then ShellLink.WorkingDirectory := AWorkingDir; if ADescription <> '' then ShellLink.Description := ADescription; if AShowCmd <> swShowNormal then ShellLink.ShowCmd := AShowCmd; if (AHotKey <> 0) then ShellLink.HotKey := AHotKey; if AHotKeyModifier <> [] then ShellLink.HotKeyModifiers := AHotKeyModifier; if AnIconLocation <> '' then ShellLink.IconLocation := AnIconLocation; if AnIconIndex <> 0 then ShellLink.IconIndex := AnIconIndex; ShellLink.WriteLink(ShellLink.FileName); except Result := False; raise; end finally ShellLink.Free end end; { ----------------------------------------------------------------------------- } { ----------------------------------------------------------------------------- } function HotKeyModifiersToStr(HotKeyMod: THotKeyModifiers): WideString; begin Result := ''; if hkmAlt in HotKeyMod then Result := Result + ' Alt'; if hkmControl in HotKeyMod then Result := Result + ' Control'; if hkmExtendedKey in HotKeyMod then Result := Result + ' ExtendedKey'; if hkmShift in HotKeyMod then Result := Result + ' Shift'; end; { ----------------------------------------------------------------------------- } { Some Stuff D4 lacks. } {$ifdef COMPILER_4} { ----------------------------------------------------------------------------- } procedure FreeAndNil(var Obj); var P: TObject; begin P := TObject(Obj); TObject(Obj) := nil; P.Free; end; { ----------------------------------------------------------------------------- } { ----------------------------------------------------------------------------- } function Supports(const Instance: IUnknown; const Intf: TGUID; out Inst): Boolean; begin Result := (Instance <> nil) and (Instance.QueryInterface(Intf, Inst) = 0); end; { ----------------------------------------------------------------------------- } {$endif} //////////////////////////////////////////////////////////////////////////////// // Local Functions //////////////////////////////////////////////////////////////////////////////// procedure PIDLQuickSort(PIDLList: TPIDLArray; const ParentFolder: IShellFolder; L, R: Integer); var I, J: Integer; P, T: PItemIDList; begin if L < R then repeat I := L; J := R; P := PIDLList[(L + R) shr 1]; repeat while ShortInt(ParentFolder.CompareIDs(0, PIDLList[I], P)) < 0 do Inc(I); while ShortInt(ParentFolder.CompareIDs(0, PIDLList[J], P)) > 0 do Dec(J); if I <= J then begin T := PIDLList[I]; PIDLList[I] := PIDLList[J]; PIDLList[J] := T; Inc(I); Dec(J); end; until I > J; if L < J then PIDLQuickSort(PIDLList, ParentFolder, L, J); L := I; until I >= R; end; procedure PIDLListQuickSort(PIDLList: TCommonPIDLList; const ParentFolder: IShellFolder; L, R: Integer); var I, J: Integer; P, T: PItemIDList; begin if L < R then repeat I := L; J := R; P := PIDLList[(L + R) shr 1]; repeat while ShortInt(ParentFolder.CompareIDs(0, PIDLList[I], P)) < 0 do Inc(I); while ShortInt(ParentFolder.CompareIDs(0, PIDLList[J], P)) > 0 do Dec(J); if I <= J then begin T := PIDLList[I]; PIDLList[I] := PIDLList[J]; PIDLList[J] := T; Inc(I); Dec(J); end; until I > J; if L < J then PIDLListQuickSort(PIDLList, ParentFolder, L, J); L := I; until I >= R; end; { ----------------------------------------------------------------------------- } function RequestedDragEffect(grfKeyState: integer): HResult; { Looks at the KeyState during a IDragTarget notification. The return value} { is the expected behavior common in Windows. Note this does not mean that } { the DragSource is actually capable of this action. } begin // Strip off the mouse button information keep only Ctrl and Shift information grfKeyState := grfKeyState and (MK_CONTROL or MK_SHIFT); // Standard Windows Shell behavior if grfKeyState = 0 then Result := DROPEFFECT_MOVE // Windows default else if grfKeyState = MK_CONTROL then Result := DROPEFFECT_COPY else if grfKeyState = (MK_CONTROL or MK_SHIFT) then Result := DROPEFFECT_LINK else Result := DROPEFFECT_NONE; end; { ----------------------------------------------------------------------------- } { ----------------------------------------------------------------------------- } { Thank you Angus Johnson for this article in UNDO } {-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-} //Structures used in GetDiskFreeSpaceFAT32 {-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-} type //DeviceIoControl registers structure... TDevIoCtl_Registers = packed record Reg_EBX : DWord; Reg_EDX : DWord; Reg_ECX : DWord; Reg_EAX : DWord; Reg_EDI : DWord; Reg_ESI : DWord; Reg_Flags : DWord; end; //Structure passed in Get_ExtFreeSpace ... TExtGetDskFreSpcStruc = packed record ExtFree_Size : Word; ExtFree_Level : Word; ExtFree_SectorsPerCluster : Integer; ExtFree_BytesPerSector : Integer; ExtFree_AvailableClusters : Integer; ExtFree_TotalClusters : Integer; ExtFree_AvailablePhysSectors : Integer; ExtFree_TotalPhysSectors : Integer; ExtFree_AvailableAllocationUnits : Integer; ExtFree_TotalAllocationUnits : Integer; ExtFree_Rsvd : array [0..1] of Integer; end; {-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-} //Angus Johnson's Delphi implimentation of - Int 21h Function 7303h Get_ExtFreeSpace (FAT32) {-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-} function GetDiskFreeSpaceFAT32(Drive: PChar; var SectorsperCluster, BytesperSector, FreeClusters, TotalClusters: DWORD): boolean; const VWIN32_DIOC_DOS_IOCTL = 6; var DevIoHandle : THandle; BytesReturned : DWord; Reg : TDevIoCtl_Registers; ExtGetDskFreSpcStruc: TExtGetDskFreSpcStruc; begin result := false; FillChar(ExtGetDskFreSpcStruc, sizeof(TExtGetDskFreSpcStruc),0); FillChar(Reg, sizeof(TDevIoCtl_Registers),0); with Reg do begin reg_EAX := $7303; reg_EDX := DWord(Drive); //DS:DX Reg_EDI := DWord(@ExtGetDskFreSpcStruc); //ES:DI reg_ECX := sizeof(TExtGetDskFreSpcStruc); reg_Flags := 1; //set carry flag to assume error. end; if IsUnicode then DevIoHandle := CreateFileW_MP( '\\.\vwin32', Generic_Read, File_Share_Read or File_Share_Write, nil, Open_Existing, File_Attribute_Normal, 0) else DevIoHandle := CreateFile( '\\.\vwin32', Generic_Read, File_Share_Read or File_Share_Write, nil, Open_Existing, File_Attribute_Normal, 0); if DevIoHandle <> Invalid_Handle_Value then begin result := DeviceIoControl(DevIoHandle, VWIN32_DIOC_DOS_IOCTL, @Reg, SizeOf(Reg), @Reg, SizeOf(Reg), BytesReturned, nil); CloseHandle(DevIoHandle); if not result then begin exit //error end else if (Reg.reg_Flags and 1 <> 0) then begin result := false; //If carry flag not cleared then => error exit; end else with ExtGetDskFreSpcStruc do begin BytesperSector := ExtFree_BytesPerSector; SectorsperCluster := ExtFree_SectorsPerCluster; TotalClusters := ExtFree_TotalClusters; FreeClusters := ExtFree_AvailableClusters; result := true; end; end; end; {GetDiskFreeSpaceFAT32} { ----------------------------------------------------------------------------- } function GetDiskFreeSpaceMP(Drive: PWideChar; var SectorsperCluster, BytesperSector, FreeClusters, TotalClusters: DWORD): boolean; begin if Assigned(GetDiskFreeSpaceW_MP) then Result := GetDiskFreeSpaceW_MP( PWideChar( Drive), SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters) else if not IsWin95_SR1 then Result := GetDiskFreeSpaceFAT32( PChar( string(Drive)), SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters) else Result := GetDiskFreeSpaceA( PChar( string(Drive)), SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters); end; function DriveSize(Drive: PWideChar): Int64; var SectorsperCluster, BytesperSector, FreeClusters, TotalClusters: DWORD; begin Result := 0; if GetDiskFreeSpaceMP(Drive, SectorsperCluster, BytesperSector, FreeClusters, TotalClusters) then Result := Int64(BytesperSector) * Int64(SectorsperCluster) * Int64(TotalClusters) end; function DriveSize(Drive: PWideChar; ByteSize: TBtyeSize): WideString; begin case ByteSize of bsKiloBytes: Result := Format('%0.0n '+ 'KB', [DriveSize(Drive) / 1024]); bsMegaBytes: Result := Format('%0.0n '+ 'MB', [DriveSize(Drive) / 1048576]); bsGigiBytes: Result := Format('%0.1n '+ 'GB', [DriveSize(Drive) / 1073741824]); bsTereBytes: Result := Format('%0.1n '+ 'TB', [DriveSize(Drive) / 1099511627776]); end end; function DriveFreeSpace(Drive: PWideChar): Int64; var SectorsperCluster, BytesperSector, FreeClusters, TotalClusters: DWORD; begin Result := 0; if GetDiskFreeSpaceMP(Drive, SectorsperCluster, BytesperSector, FreeClusters, TotalClusters) then Result := Int64(BytesperSector) * Int64(SectorsperCluster) * Int64(FreeClusters) end; function DriveFreeSpace(Drive: PWideChar; ByteSize: TBtyeSize): WideString; begin case ByteSize of bsKiloBytes: Result := Format('%0.0n '+ 'KB', [DriveFreeSpace(Drive) / 1024]); bsMegaBytes: Result := Format('%0.0n '+ 'MB', [DriveFreeSpace(Drive) / 1048576]); bsGigiBytes: Result := Format('%0.1n '+ 'GB', [DriveFreeSpace(Drive) / 1073741824]); bsTereBytes: Result := Format('%0.1n '+ 'TB', [DriveFreeSpace(Drive) / 1099511627776]); end end; { ----------------------------------------------------------------------------- } function LoadShell32Functions: Boolean; var ShellDLL: HMODULE; begin { Don't see a point in making this all WideString compatible } ShellDLL := GetModuleHandle(PChar(Shell32)); // ShellDLL := LoadLibrary(PChar(Shell32)); if ShellDll <> 0 then begin AnimateWindow := GetProcAddress(GetModuleHandle('user32'), 'AnimateWindow'); ShellILIsEqual := GetProcAddress(ShellDLL, PChar(21)); ShellILIsParent := GetProcAddress(ShellDLL, PChar(23)); SHLimitInputEdit := GetProcAddress(ShellDLL, PChar(747)); Result := Assigned(ShellILIsEqual) and Assigned(ShellILIsParent) end else Result := False; end; { ----------------------------------------------------------------------------- } { TNamespace } function TNamespace.CanCopyAll(NamespaceArray: TNamespaceArray): Boolean; var i: integer; begin if Assigned(NamespaceArray) then begin Result := True; i := 0; while Result and (i < Length(NamespaceArray)) do begin Result := NamespaceArray[i].CanCopy; Inc(i) end end else Result := False end; function TNamespace.CanCutAll(NamespaceArray: TNamespaceArray): boolean; begin Result := CanDeleteAll(NamespaceArray) end; function TNamespace.CanDeleteAll(NamespaceArray: TNamespaceArray): Boolean; var i: integer; begin if Assigned(NamespaceArray) then begin Result := True; i := 0; while Result and (i < Length(NamespaceArray)) do begin Result := NamespaceArray[i].CanDelete; Inc(i) end end else Result := False end; function TNamespace.CanPasteToAll(NamespaceArray: TNamespaceArray): Boolean; begin Result := False; if Assigned(NamespaceArray) then if Length(NamespaceArray) > 0 then Result := True // Can try to paste to anything? end; function TNamespace.CanShowPropertiesOfAll(NamespaceArray: TNamespaceArray): Boolean; var i: integer; begin if Assigned(NamespaceArray) then begin Result := True; i := 0; while Result and (i < Length(NamespaceArray)) do begin Result := NamespaceArray[i].HasPropSheet; Inc(i) end end else Result := False end; function TNamespace.Clone(ReleasePIDLOnDestroy: Boolean): TNameSpace; begin // This is not really a true clone since we don't copy the parent, but it is // dangerous to do that. Be careful using this function since things can // potentially change in the shell. Result := TNamespace.Create(PIDLMgr.CopyPIDL(AbsolutePIDL), nil); Result.FreePIDLOnDestroy := ReleasePIDLOnDestroy; end; function TNamespace.ComparePIDL(PIDLToCompare: PItemIDList; IsAbsolutePIDL: Boolean; Column: Integer = 0): ShortInt; // Encapsulation of the CompareID Function of IShellFolder // Returns > 0 if PIDLToCompare > RelativePIDL // 0 if PIDLToCompare = RelativePIDL // < 0 if PIDLToCompare < RelativePIDL var PIDL: PItemIDList; begin if Assigned(PIDLToCompare) then begin if Column < 0 then Column := 0; if PIDLMgr.IsDesktopFolder(PIDLToCompare) and IsDesktop then Result := 0 else begin PIDL := PIDLMgr.GetPointerToLastID(PIDLToCompare); if Assigned(ParentShellFolder) then begin if IsAbsolutePIDL then begin Result := -1; // First test is if the PIDL length is the same if PIDLMgr.IDCount(PIDLToCompare) = PIDLMgr.IDCount(AbsolutePIDL) then begin if Assigned(Parent) then begin // Desktop items won't have a valid parent if ILIsParent(Parent.AbsolutePIDL, PIDLToCompare, True) then Result := ShortInt(ParentShellFolder.CompareIDs(Column, PIDL, RelativePIDL)) end else Result := ShortInt(ParentShellFolder.CompareIDs(Column, PIDL, RelativePIDL)) end end else Result := ShortInt(ParentShellFolder.CompareIDs(Column, PIDL, RelativePIDL)); end else Result := 0 end end else Result := -1 // If the pidl is not assigned then we clearly are greater! end; function TNamespace.ContextMenuItemHelp(MenuItemID: LongWord): WideString; const BufferLen = 128; var S: string; Found: Boolean; P: Pointer; begin Found := False; if Assigned(CurrentContextMenu) and (MenuItemID <> $FFFFFFFF) and (MenuItemID > 0)then begin if IsUnicode then begin SetLength(Result, BufferLen); { Keep D6 from complaining about suspicious PChar cast } P := @Result[1]; Found := CurrentContextMenu.GetCommandString(MenuItemID-1, GCS_HELPTEXTW, nil, PChar(P), BufferLen) = NOERROR end; if not Found then begin SetLength(S, BufferLen); if CurrentContextMenu.GetCommandString(MenuItemID-1, GCS_HELPTEXTA, nil, PChar(S), BufferLen) <> NOERROR then Result := '' else begin SetLength(S, StrLen( PChar(S))); Result := S end end else SetLength(Result, lstrlenW(PWideChar( Result))) end; end; function TNamespace.ContextMenuVerb(MenuItemID: Longword): WideString; { Returns the cononical (or not) verb that is equal to the MenuItemID, which is } { the HMenu identifer for a menu item. } const BufferLen = 128; var S: string; Found: Boolean; P: Pointer; begin Found := False; if Assigned(CurrentContextMenu) and (MenuItemID <> $FFFFFFFF) and (MenuItemID > 0) then begin if IsUnicode then begin SetLength(Result, BufferLen); { Keep D6 from complaining about suspicious PChar cast } P := @Result[1]; Found := CurrentContextMenu.GetCommandString(MenuItemID-1, GCS_VERBW, nil, PChar(P), BufferLen) = NOERROR end; if not Found then begin SetLength(S, BufferLen); if CurrentContextMenu.GetCommandString(MenuItemID-1, GCS_VERBA, nil, PChar(S), BufferLen) <> NOERROR then Result := '' else begin SetLength(S, StrLen( PChar(S))); Result := S end end else SetLength(Result, lstrlenW(PWideChar( Result))) end; end; function TNamespace.Copy(NamespaceArray: TNamespaceArray): Boolean; begin Result := False; if CanCopyAll(NamespaceArray) then begin if VerifyPIDLRelationship(NamespaceArray, True) then Result := ExecuteContextMenuVerb('copy', NamespaceToRelativePIDLArray(NamespaceArray)) else ExecuteContextMenuVerbMultiPath('copy', NamespaceArray) end end; constructor TNamespace.Create(PIDL: PItemIdList; AParent: TNamespace); { Pass the PIDL of a Namespace Object Folder to create along with its parent } { to create a new TNamespace. } begin inherited Create; FParent := AParent; FShellCache.Data.SmallIcon := -1; FShellCache.Data.SmallOpenIcon := -1; FShellCache.Data.OverlayIndex := -1; FShellCache.Data.OverlayIconIndex := -1; Include(FStates, nsShellDetailsSupported); // Be optomistic Include(FStates, nsShellFolder2Supported); // Be optomistic Include(FStates, nsShellOverlaySupported); // Be optomistic FreePIDLOnDestroy := True; FNamespaceID := SHELL_NAMESPACE_ID; { It is the Root Folder since it has no parent } if not Assigned(AParent) then begin { Either a nil for PID or if the PID is the Desktop PIDL means a full tree } if not Assigned(PIDL) or PIDLMgr.IsDesktopFolder(PIDL) then begin { If PID is already assigned then use it } if not Assigned(PIDL) then SHGetSpecialFolderLocation(ParentWnd, CSIDL_DESKTOP, FRelativePIDL) else FRelativePIDL := PIDL; FAbsolutePIDL := FRelativePIDL; end else { The PIDL is the Root PIDL but is NOT the Desktop namespace it is a } { FULLY QUALIFIED PIDL to a namespace that is to be the Root. } begin FAbsolutePIDL := PIDL; FRelativePIDL := PIDLMgr.GetPointerToLastID(FAbsolutePIDL); end; end else { If the folder is a child of the desktop special conditions apply see above } if PIDLMgr.IsDesktopFolder(AParent.AbsolutePIDL) then begin FRelativePIDL := PIDL; FAbsolutePIDL := PIDL; end else { Normal building of the PIDLs and Shells } begin FAbsolutePIDL := PIDLMgr.AppendPIDL(AParent.FAbsolutePIDL, PIDL); FRelativePIDL := PIDLMgr.GetPointerToLastID(FAbsolutePIDL); PIDLMgr.FreePIDL(PIDL); end; end; constructor TNamespace.CreateCustomNamespace(CustomID: Integer; AParent: TNamespace); begin FShellCache.Data.SmallIcon := -1; FShellCache.Data.SmallOpenIcon := -1; Exclude(FStates, nsShellDetailsSupported); Exclude(FStates, nsShellFolder2Supported); FreePIDLOnDestroy := False; FNamespaceID := CustomID; FParent := AParent end; constructor TNamespace.CreateFromFileName(FileName: WideString); var PIDL: PItemIDList; begin PIDL := PathToPIDL(FileName); if Assigned(PIDL) then Create(PIDL, nil) else // This will be called often with the autocomplete component while debugging // in the IDE // To turn off exception break go to Tools>Debugger Options>Add and type in // "EVSTInvalidFileName" without the quotes. Make sure that is is checked. // This will keep delphi from breaking on this exception raise EVSTInvalidFileName.Create('Trying to create a TNamespace on a non existant File object'); end; function TNamespace.Cut(NamespaceArray: TNamespaceArray): Boolean; begin Result := False; if CanCutAll(NamespaceArray) then begin if VerifyPIDLRelationship(NamespaceArray, True) then Result := ExecuteContextMenuVerb('cut', NamespaceToRelativePIDLArray(NamespaceArray)) else ExecuteContextMenuVerbMultiPath('cut', NamespaceArray) end end; function TNamespace.DataObjectMulti(NamespaceArray: TNamespaceArray): IDataObject; begin if VerifyPIDLRelationship(NamespaceArray, True) then Result := InternalGetDataObjectInterface(NamespaceToRelativePIDLArray(NamespaceArray)) else CreateFullyQualifiedShellDataObject(NamespaceToAbsolutePIDLArray(NamespaceArray), Result); end; function TNamespace.Delete(NamespaceArray: TNamespaceArray): Boolean; begin Result := False; if CanDeleteAll(NamespaceArray) then begin if VerifyPIDLRelationship(NamespaceArray, True) then Result := ExecuteContextMenuVerb('delete', NamespaceToRelativePIDLArray(NamespaceArray)) else ExecuteContextMenuVerbMultiPath('delete', NamespaceArray) end end; destructor TNamespace.Destroy; begin // Remember RelativePIDL points to end of AbsolutePIDL so only 1 actual PIDL. if FreePIDLOnDestroy and Assigned(PIDLMgr) then PIDLMgr.FreePIDL(FAbsolutePIDL); if IsUnicode then begin if Assigned(FWin32FindDataW) then FreeMem(FWin32FindDataW, SizeOf(TWin32FindDataW)); end else if Assigned(FWin32FindDataA) then FreeMem(FWin32FindDataA, SizeOf(TWin32FindDataA)); begin end; if Assigned(FSHGetFileInfoRec) then begin Finalize(FSHGetFileInfoRec^); FreeMem(FSHGetFileInfoRec, SizeOf(TSHGetFileInfoRec)); end; FreeAndNil(FExtractImage); FreeAndNil(FShellLink); FShellFolder := nil; FreeAndNIL(FImage); inherited; if (nsOwnsParent in States) then FreeAndNil(FParent); end; function TNamespace.DetailsAlignment(ColumnIndex: Integer): TAlignment; { Returns the Text that is in the Header of the Explorer Listview based on what } { the folder in the Treeview is displaying. Only implemented partially on } { different versions of Windows. It was undocumented until about Win98. } { Win2k implements this using IShellFolder2 } { Be careful of the reference point using DetailsXXXX functions. This method } { get the header titles a folder will show for its children. } var Details: TShellDetails; Found: Boolean; begin // Default Result := taLeftJustify; FillChar(Details, SizeOf(Details), #0); Found := False; if DetailsValidIndex(ColumnIndex) then begin if Assigned(ShellFolder2) then Found := ShellFolder2.GetDetailsOf(nil, UINT(ColumnIndex), Details) = S_OK; if not Found and Assigned(ShellDetailsInterface) then Found := ShellDetailsInterface.GetDetailsOf(nil, UINT(ColumnIndex), Details) = S_OK; if Found then begin case Details.Fmt of LVCFMT_CENTER: Result := taCenter; LVCFMT_LEFT: Result := taLeftJustify; LVCFMT_RIGHT: Result := taRightJustify; // LVCFMT_COL_HAS_IMAGES: Result := tiContainsImage end; if (Details.str.uType = STRRET_WSTR) and Assigned(Details.str.pOleStr) then PIDLMgr.FreeOLEStr(Details.str.pOLEStr); end end end; function TNamespace.DetailsColumnTitle(ColumnIndex: integer): WideString; { Returns the Text that is in the Header of the Explorer Listview based on what } { the folder in the Treeview is displaying. Only implemented partially on } { different versions of Windows. It was undocumented until about Win98. } { Win2k implements this using IShellFolder2 } { Be careful of the reference point using DetailsXXXX functions. This method } { gets the header titles a folder will show for its children. } var Details: TShellDetails; Found: Boolean; begin FillChar(Details, SizeOf(Details), #0); Found := False; if DetailsValidIndex(ColumnIndex) then begin if Assigned(ShellFolder2) then Found := ShellFolder2.GetDetailsOf(nil, UINT(ColumnIndex), Details) = S_OK; if not Found and Assigned(ShellDetailsInterface) then Found := ShellDetailsInterface.GetDetailsOf(nil, UINT(ColumnIndex), Details) = S_OK; if Found then Result := StrRetToStr(Details.str, RelativePIDL) else Result := DetailsDefaultColumnTitle(ColumnIndex) end else Result := '' end; function TNamespace.DetailsDefaultColumnTitle(ColumnIndex: integer): WideString; { If IShellDetails is not implemented then these are returned for the Header } { text as a default. Can be overridden. } begin case ColumnIndex of -1, 0: Result := STR_COLUMN_NAMES[0]; 1: Result := STR_COLUMN_NAMES[1]; 2: Result := STR_COLUMN_NAMES[2]; 3: Result := STR_COLUMN_NAMES[3]; 4: Result := STR_COLUMN_NAMES[4]; 5: Result := STR_COLUMN_NAMES[5]; 6: Result := STR_COLUMN_NAMES[6]; 7: Result := STR_COLUMN_NAMES[7]; 8: Result := STR_COLUMN_NAMES[8]; 9: Result := STR_COLUMN_NAMES[9]; end; end; function TNamespace.DetailsDefaultOf(ColumnIndex: integer): WideString; { If IShellDetail is not implemented the call to DetailsOf calls this and } { returns what it can to mimic the values in columns for a plain file, Name, } { size, type, date, attributes. } var IsSystemFolder: Boolean; begin Result := ''; if IsUnicode then begin if not Assigned(FWin32FindDataW) then GetDataFromIDList; if Assigned(FWin32FindDataW) then { This is totally undocumented. It works on Win98 will test on NT 4 soon } { Not a valid file so it has no size. #8 appears to mean "System File" } IsSystemFolder := not ((FWin32FindDataW^.cFileName[0] = WideChar(#8)) or (FWin32FindDataW^.cFileName[0] = WideChar(#0)) or not FileSystem) else IsSystemFolder := False; end else begin if not Assigned(FWin32FindDataA) then GetDataFromIDList; if Assigned(FWin32FindDataA) then { This is totally undocumented. It works on Win98 will test on NT 4 soon } { Not a valid file so it has no size. #8 appears to mean "System File" } IsSystemFolder := not ((FWin32FindDataA^.cFileName[0] = #8) or (FWin32FindDataA^.cFileName[0] = #0) or not FileSystem) else IsSystemFolder := False; end; case ColumnIndex of -1, 0: Result := NameInFolder; 1: Result := SizeOfFileKB; 2: if IsSystemFolder then Result := FileType else Result := STR_SYSTEMFOLDER; 3: Result := LastWriteTime; 4: Result := AttributesString; else Result := '' end; end; function TNamespace.DetailsDefaultSupportedColumns: integer; { If IShellDetail is not implemented the call to SupportedColumns calls this } { and returns 5. It mimics the titles in the header for a plain file, Name, } { size, type, date, attributes. } begin Result := DefaultDetailColumns; end; function TNamespace.DetailsGetDefaultColumnState(ColumnIndex: integer): TSHColumnStates; { Be careful of the reference point using DetailsXXXX functions. This function } { gets the GetDefaultColumnState of the folder for its children if it exposes } { IShellFolder2. If it does not it returns csOnByDefault so it will be shown } var Flags: Longword; begin Result := []; // Assert(DetailsValidIndex(ColumnIndex), 'Invalid DetailsGetDefaultColumnState in TNamespace.DetailsOf'); if DetailsValidIndex(ColumnIndex) then begin EnsureDetailCache; if (docStatesValid in ShellCache.Data.DetailsOfCache[ColumnIndex].Cached) then Result := ShellCache.Data.DetailsOfCache[ColumnIndex].States else begin if Assigned(ShellFolder2) then begin Flags := 0; if ShellFolder2.GetDefaultColumnState(ColumnIndex, Flags) = NOERROR then begin if SHCOLSTATE_TYPE_STR and Flags <> 0 then Include(ShellCache.Data.DetailsOfCache[ColumnIndex].States, csTypeString); if SHCOLSTATE_TYPE_INT and Flags <> 0 then Include(ShellCache.Data.DetailsOfCache[ColumnIndex].States, csTypeInt); if SHCOLSTATE_TYPE_DATE and Flags <> 0 then Include(ShellCache.Data.DetailsOfCache[ColumnIndex].States, csTypeDate); if SHCOLSTATE_ONBYDEFAULT and Flags <> 0 then Include(ShellCache.Data.DetailsOfCache[ColumnIndex].States, csOnByDefault); if SHCOLSTATE_TYPE_SLOW and Flags <> 0 then Include(ShellCache.Data.DetailsOfCache[ColumnIndex].States, csSlow); if SHCOLSTATE_EXTENDED and Flags <> 0 then Include(ShellCache.Data.DetailsOfCache[ColumnIndex].States, csExtended); if SHCOLSTATE_SECONDARYUI and Flags <> 0 then Include(ShellCache.Data.DetailsOfCache[ColumnIndex].States, csSecondaryUI); if SHCOLSTATE_HIDDEN and Flags <> 0 then Include(ShellCache.Data.DetailsOfCache[ColumnIndex].States, csHidden); end else { Some of the old namespaces will expose ShellFolder2 but don't support } { it completely. These resort to IShellDetails so assume this is the case } ShellCache.Data.DetailsOfCache[ColumnIndex].States := [csOnByDefault]; end else { Some of the old namespaces don't expose ShellFolder2. These resort to } { IShellDetails so assume this is the case } ShellCache.Data.DetailsOfCache[ColumnIndex].States := [csOnByDefault]; Result := ShellCache.Data.DetailsOfCache[ColumnIndex].States; Include(ShellCache.Data.DetailsOfCache[ColumnIndex].Cached, docStatesValid) end end end; function TNamespace.DetailsOf(ColumnIndex: integer): WideString; { Returns the text for the desired column (detail view in the listview in } { Explorer) using IShellDetail or using information pulled from the namespace } { by other means. } { Be careful of the reference point using DetailsXXXX functions. This function } { gets the Details of the current namespace using its parent folder. } // Threading only works on Namespaces that support IShellFolder2 (WinME, Win2k and up) var Details: TShellDetails; OldError: Integer; TempCache: PDetailsOfCacheRec; begin Result := ''; if DetailsValidIndex(ColumnIndex) then begin OldError := SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOOPENFILEERRORBOX); try { Force parent namespace creation if necessary } if Assigned(ParentShellFolder) and not IsDesktop then begin { The parent is responsible for the columns } if DetailsValidIndex(ColumnIndex) then begin EnsureDetailCache; if (docCaptionValid in ShellCache.Data.DetailsOfCache[ColumnIndex].Cached) then Result := ShellCache.Data.DetailsOfCache[ColumnIndex].Caption else begin FillChar(Details, SizeOf(Details), #0); TempCache := @ShellCache.Data.DetailsOfCache[ColumnIndex]; if ColumnIndex = 0 then TempCache^.Caption := NameInFolder else if Assigned(ParentShellFolder2) then begin if ParentShellFolder2.GetDetailsOf(RelativePIDL, UINT(ColumnIndex), Details) <> S_OK then begin if Assigned(ParentShellDetailsInterface) and (ParentShellDetailsInterface.GetDetailsOf(RelativePIDL, UINT(ColumnIndex), Details) = S_OK) then TempCache^.Caption := StrRetToStr(Details.Str, RelativePIDL) else TempCache^.Caption := DetailsDefaultOf(ColumnIndex) end else TempCache^.Caption := StrRetToStr(Details.Str, RelativePIDL); Include(TempCache^.Cached, docCaptionValid) end else begin if Assigned(ParentShellDetailsInterface) then begin if ParentShellDetailsInterface.GetDetailsOf(RelativePIDL, UINT(ColumnIndex), Details) = S_OK then TempCache^.Caption := StrRetToStr(Details.Str, RelativePIDL); end else TempCache^.Caption := DetailsDefaultOf(ColumnIndex); Include(TempCache^.Cached, docCaptionValid); end; Result := TempCache^.Caption; end end end finally SetErrorMode(OldError); end end end; function TNamespace.DetailsOfEx(ColumnIndex: integer): WideString; var ColumnID: TSHColumnID; V: OLEVariant; ColState: TSHColumnStates; // Date: TDateTime; begin Result := ''; V := Null; if Assigned(ParentShellFolder2) then begin ColState := Parent.DetailsGetDefaultColumnState(ColumnIndex); FillChar(ColumnID, SizeOf(ColumnID), #0); if ParentShellFolder2.MapColumnToSCID(ColumnIndex, ColumnID) = NOERROR then if ParentShellFolder2.GetDetailsEx(RelativePIDL, ColumnID, V) = NOERROR then begin if csTypeString in ColState then Result := WideString(V) else if csTypeInt in ColState then Result := IntToStr( Integer(V)) else // if csTypeDate in ColState then // Date := V; end else Result := DetailsDefaultOf(ColumnIndex) else Result := DetailsDefaultOf(ColumnIndex) end end; function TNamespace.DetailsSupportedColumns: integer; { If IShellDetail or IShellFolder2 is implemented the call to } { DetailsSupportedColumns returns total number of columns the namespace } { supports. This allows the header to change dynamiclly. } { Be careful of the reference point using DetailsXXXX functions. This function } { gets number of columns this folder will display for its children. } const { ShellFolder2 is broken on WinME for "Scanners and Cameras" folders. } { It goes into an infinate loop. } { WinXP is just as broken. } COLUMNLIMIT = 1000; // Safely valve for namespaces that don't follow the rules var Details: TShellDetails; Flags: DWord; Found: Boolean; begin FillChar(Details, SizeOf(Details), #0); if not (scSupportedColumns in ShellCache.ShellCacheFlags) then begin FShellCache.Data.SupportedColumns := 0; if Assigned(ShellFolder2) then begin while (ShellFolder2.GetDefaultColumnState(FShellCache.Data.SupportedColumns, Flags) = NOERROR) and (FShellCache.Data.SupportedColumns < COLUMNLIMIT) do Inc(FShellCache.Data.SupportedColumns); // Error detected, the namespace does not follow the rules if FShellCache.Data.SupportedColumns = COLUMNLIMIT then FShellCache.Data.SupportedColumns := 0; Found := FShellCache.Data.SupportedColumns > 0; { Some folders support both methods but only work right with GetDetailsOf } if not Found then while (ShellFolder2.GetDetailsOf(nil, UINT(ShellCache.Data.SupportedColumns), Details) = S_OK) and (FShellCache.Data.SupportedColumns < COLUMNLIMIT) do begin Inc(FShellCache.Data.SupportedColumns); if (Details.str.uType = STRRET_WSTR) and Assigned(Details.str.pOleStr) then PIDLMgr.FreeOLEStr(Details.str.pOLEStr); end; // Error detected, the namespace does not follow the rules if FShellCache.Data.SupportedColumns = COLUMNLIMIT then FShellCache.Data.SupportedColumns := 0; end; { Some folders support both but only work right with IShellDetials } { The History Folder is an example. } Found := FShellCache.Data.SupportedColumns > 0; { DO NOT PASS A FREAKING UNInitialIZED TSHELLDETAIL STRUCTURE TO THIS FUNCTION } { IT WILL CAUSE THE RESULT TO BE CORRECT BUT INTERLACED WITH GARBAGE. } if not Found and Assigned(ShellDetailsInterface) then while ShellDetailsInterface.GetDetailsOf(nil, UINT(ShellCache.Data.SupportedColumns), Details) = S_OK do Inc(FShellCache.Data.SupportedColumns); if ShellCache.Data.SupportedColumns = 0 then FShellCache.Data.SupportedColumns := DetailsDefaultSupportedColumns; Include(FShellCache.ShellCacheFlags, scSupportedColumns); end; Result := ShellCache.Data.SupportedColumns end; function TNamespace.DetailsSupportedVisibleColumns: TVisibleColumnIndexArray; // Returns and array of currently visible columns in details mode. Two bits of info // are returned with this method. // 1) The number of visible column: Length(DetailsSupportedVisibleColumns) // 2) The indicies of visible columns: [0, 2, 4, 6] Details index 0, 2, 4, 6 are shown\ var i: integer; begin Result := nil; for i := 0 to DetailsSupportedColumns - 1 do begin if csOnByDefault in DetailsGetDefaultColumnState(i) then begin if DetailsColumnTitle(i) <> '' then begin SetLength(Result, Length(Result) + 1); Result[Length(Result) - 1] := i end end end; end; function TNamespace.DetailsValidIndex(DetailsIndex: integer): Boolean; { Test to see if the passed index is in the range of the number of detail } { columns the namespace has. } begin Result := (DetailsIndex > -1) and (DetailsIndex < DetailsSupportedColumns) end; function TNamespace.DragEffect(grfKeyState: integer): HRESULT; { Looks at the KeyState during a IDragDrop notification. The return value } { is the Effect that is desired by the user, using the GetDesiredDragEffect} { function, and what Effects are supported by the IDragSource } function AvailableEffects: LongInt; begin Result := DROPEFFECT_NONE; if CanMove then Result := DROPEFFECT_MOVE; if CanCopy then Result := Result or DROPEFFECT_COPY; if CanLink then Result := Result or DROPEFFECT_LINK; end; var KeyEffect: HResult; ValidEffects: Longword; begin // See what the user is requesting by looking at the key board KeyEffect := RequestedDragEffect(grfKeyState); // What effects do the namespace support? ValidEffects := AvailableEffects; // Let the users desires prevail if KeyEffect and ValidEffects > 0 then Result := KeyEffect else // If the users desires are undo-able pick the first effect avaiable if ValidEffects and DROPEFFECT_MOVE > 1 then Result := DROPEFFECT_MOVE else // Windows default is MOVE so check it first if ValidEffects and DROPEFFECT_COPY > 1 then Result := DROPEFFECT_COPY else if ValidEffects and DROPEFFECT_LINK > 1 then Result := DROPEFFECT_LINK else Result := DROPEFFECT_NONE; end; function TNamespace.DisplayNameOf(Flags: Longword): WideString; var StrRet: TSTRRET; begin if Assigned(ParentShellFolder) then begin FillChar(StrRet, SizeOf(StrRet), #0); if ParentShellFolder.GetDisplayNameOf(RelativePIDL, Flags, StrRet) = NOERROR then Result := StrRetToStr(StrRet, RelativePIDL) else Result := ''; end else Result := '' end; function TNamespace.DragEnter(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult; { Called when there is a pending COM drop on the namespace. The namespace will } { decide if it can handle the information passed. } begin if DropTarget and Assigned(DropTargetInterface) then Result := DropTargetInterface.DragEnter(dataObj, grfKeyState, pt, dwEffect) else begin dwEffect := DROPEFFECT_NONE; Result := S_OK end end; function TNamespace.DragLeave: HResult; { Called when there is a pending COM drop on the namespace. The namespace will } { decide if it can handle the information passed. } begin if DropTarget and Assigned(DropTargetInterface) then Result := DropTargetInterface.DragLeave else Result := S_OK end; function TNamespace.DragOver(grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult; { Called when there is a pending COM drop on the namespace. The namespace will } { decide if it can handle the information passed. } begin if DropTarget and Assigned(DropTargetInterface) then Result := DropTargetInterface.DragOver(grfKeyState, pt, dwEffect) else begin dwEffect := DROPEFFECT_NONE; Result := S_OK end end; function TNamespace.Drop(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult; { Called when there is a COM object is dropped on the namespace. The namespace } { will handle the action as well. } begin if DropTarget and Assigned(DropTargetInterface) then Result := DropTargetInterface.Drop(dataObj, grfKeyState, pt, dwEffect) else begin dwEffect := DROPEFFECT_NONE; Result := S_OK end end; function TNamespace.EnumerateFolder(MessageWnd: HWnd; Folders, NonFolders, IncludeHidden: Boolean; EnumFunc: TEnumFolderCallback; UserData: Pointer): integer; { Enumerate a folder to get its subfolders. For each subfolder the the } { callback function is called so a new TNamespace may be created. } { You have a choice to receive Folders, NonFolders (files), and Hidden } { objects, UserData is useful to pass info back to the callback function. } { Encapsulates the IShellFolder.EnumObjects function } { The reciever of the Callback function is responsible for Freeing the PIDLs! } { Returns the number of objects in the folder. } var Enum: IEnumIDList; Flags: Longword; Fetched: Longword; Item: PItemIDList; Terminate: Boolean; OldError: integer; begin Result := 0; { This fixed a problem Rik Baker had: } { "The error message is "C:\WINDOWS\SYSTEM\ODBCINST.DLL is not a valid } { Windows Image", however the file appears fine and I've now seen the same } { message on 9 different 2000 boxes spread across the country. } OldError := SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOOPENFILEERRORBOX); try if Assigned(ShellFolder) then begin if Assigned(EnumFunc) then begin Terminate := False; Flags := 0; if Folders then Flags := Flags or SHCONTF_FOLDERS; if NonFolders then Flags := Flags or SHCONTF_NONFOLDERS; if IncludeHidden then Flags := Flags or SHCONTF_INCLUDEHIDDEN; if Valid then begin // Right now you can't mix custom items and real shell items in the same folder if ShellFolder.EnumObjects(MessageWnd, Flags, Enum) = NOERROR then begin // Vista Enum is nil every once in a while if Assigned(Enum) then begin while (Enum.Next(1, Item, Fetched) = NOERROR) and not Terminate do begin if EnumFunc(MessageWnd, Item, Self, UserData, Terminate) then Inc(Result) end end end end end end finally SetErrorMode(OldError); end end; function TNamespace.EnumerateFolderEx(MessageWnd: HWnd; FileObjects: TFileObjects; EnumFunc: TEnumFolderCallback; UserData: pointer; AfterValidEnumIDList: TNotifyEvent = nil): integer; { Enumerate a folder to get its subfolders. For each subfolder the the } { callback function is called so a new TNamespace may be created. } { You have a choice to receive Folders, NonFolders (files), and Hidden } { objects, UserData is useful to pass info back to the callback function. } { Encapsulates the IShellFolder.EnumObjects function } { The reciever of the Callback function is responsible for Freeing the PIDLs! } { Returns the number of objects in the folder. } var Enum: IEnumIDList; Flags: Longword; Fetched: Longword; Item: PItemIDList; Terminate: Boolean; OldError: integer; begin Result := 0; { This fixed a problem Rik Baker had: } { "The error message is "C:\WINDOWS\SYSTEM\ODBCINST.DLL is not a valid } { Windows Image", however the file appears fine and I've now seen the same } { message on 9 different 2000 boxes spread across the country. } OldError := SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOOPENFILEERRORBOX); try if not MP_UseModalDialogs then MessageWnd := 0; if Assigned(ShellFolder) then begin Flags := FileObjectsToFlags(FileObjects); Terminate := False; if Valid then begin // Right now you can't mix custom items and real shell items in the same folder if ShellFolder.EnumObjects(MessageWnd, Flags, Enum) = NOERROR then begin // Vista Enum is nil every once in a while if Assigned(Enum) then begin if Assigned(AfterValidEnumIDList) then AfterValidEnumIDList(Self); // Allows calling with a nil EnumFunc to pop messages in the EnumObjects call above if not Assigned(EnumFunc) then EnumFunc := EnumFuncDummy; if Assigned(Enum) then while (Enum.Next(1, Item, Fetched) = NOERROR) and not Terminate do begin if EnumFunc(MessageWnd, Item, Self, UserData, Terminate) then Inc(Result) end end end end end finally SetErrorMode(OldError); end end; function TNamespace.ExecuteContextMenuVerb(AVerb: WideString; APIDLArray: TRelativePIDLArray; MessageWindowParent: HWnd = 0): Boolean; const MaxVerbLen = 128; var ContextMenu, ContextMenu2: IContextMenu; Menu: hMenu; InvokeInfo: TCMInvokeCommandInfoEx; i: integer; VerbA, AVerbA: string; VerbW: WideString; VerbFound, StrFound: Boolean; MenuID: LongWord; GenericVerb: Pointer; begin if Assigned(ParentShellFolder) then begin if Assigned(APIDLArray) then ContextMenu := InternalGetContextMenuInterface(APIDLArray) else ContextMenu := ContextMenuInterface; if Assigned(ContextMenu) then ContextMenu.QueryInterface(IID_IContextMenu2, ContextMenu2); Menu := CreatePopupMenu; if Assigned(ContextMenu) or Assigned(ContextMenu2) then begin try if Assigned(ContextMenu2) then ContextMenu2.QueryContextMenu(Menu, 0, 1, $7FFF, CMF_NORMAL or CMF_EXPLORE or CMF_DEFAULTONLY) else ContextMenu.QueryContextMenu(Menu, 0, 1, $7FFF, CMF_NORMAL or CMF_EXPLORE or CMF_DEFAULTONLY); FillChar(InvokeInfo, SizeOf(InvokeInfo), #0); if IsUnicode then begin SetLength(VerbW, MaxVerbLen); GenericVerb := @VerbW[1]; end else begin SetLength(VerbA, MaxVerbLen); GenericVerb := @VerbA[1];; AVerbA := AVerb end; VerbFound := False; i := 0; { The result of using the 'verb' string and the MakeIntResource is } { different expecially on system folders. This forces it to use } { MakeIntResource if it can. } while (i < GetMenuItemCount(Menu)) and not VerbFound do begin MenuID := GetMenuItemID(Menu, i); if (MenuID <> $FFFFFFFF) and (MenuID > 0) then begin FillChar(GenericVerb^, Length(VerbW) * 2, #0); if IsUnicode then begin if Assigned(ContextMenu2) then StrFound := Succeeded(ContextMenu2.GetCommandString(MenuID-1, GCS_VERBW, nil, GenericVerb, MaxVerbLen)) else StrFound := Succeeded(ContextMenu.GetCommandString(MenuID-1, GCS_VERBW, nil, GenericVerb, MaxVerbLen)); if StrFound then begin SetLength(VerbW, lstrlenW(PWideChar( VerbW))); if lstrcmpiW_MP(PWideChar(VerbW), PWideChar(AVerb)) = 0 then begin InvokeInfo.fMask := CMIC_MASK_UNICODE; { For some reason the lpVerbW won't work } InvokeInfo.lpVerb := MakeIntResourceA(MenuID-1); InvokeInfo.lpVerbW := MakeIntResourceW(MenuID-1); VerbFound := True end; SetLength(VerbW, MaxVerbLen); end end else begin if Assigned(ContextMenu2) then StrFound := Succeeded(ContextMenu2.GetCommandString(MenuID-1, GCS_VERB, nil, GenericVerb, MaxVerbLen)) else StrFound := Succeeded(ContextMenu.GetCommandString(MenuID-1, GCS_VERB, nil, GenericVerb, MaxVerbLen)); if StrFound then begin SetLength(VerbA, StrLen(PChar( VerbA))); if lstrcmpi(PChar( VerbA), PChar(AVerbA)) = 0 then begin InvokeInfo.lpVerb := MakeIntResourceA(MenuID-1); VerbFound := True end; SetLength(VerbA, MaxVerbLen); end end end; Inc(i) end; if not VerbFound then begin if IsUnicode then begin InvokeInfo.fMask := CMIC_MASK_UNICODE; InvokeInfo.lpVerbW := PWideChar( AVerb); InvokeInfo.lpVerb := PChar( string( AVerb)) end else InvokeInfo.lpVerb := PChar( AVerbA); end; if IsUnicode then InvokeInfo.cbSize := SizeOf(TCMInvokeCommandInfoEx) else InvokeInfo.cbSize := SizeOf(TCMInvokeCommandInfo); if MessageWindowParent = 0 then InvokeInfo.hWnd := ParentWnd else InvokeInfo.hWnd := MessageWindowParent; InvokeInfo.nShow := SW_SHOWNORMAL; if Assigned(ContextMenu2) then Result := Succeeded(ContextMenu2.InvokeCommand(InvokeInfo)) else Result := Succeeded(ContextMenu.InvokeCommand(InvokeInfo)) finally if Menu <> 0 then DestroyMenu(Menu); end; end else Result := False end else Result := False end; function TNamespace.FolderSize(Invalidate: Boolean; RecurseFolder: Boolean = False): Int64; begin if not(scFolderSize in ShellCache.ShellCacheFlags) or Invalidate then begin if Folder and FileSystem then FShellCache.Data.FolderSize := CalcuateFolderSize(NameForParsing, RecurseFolder); Include(FShellCache.ShellCacheFlags, scFolderSize); end; Result := FShellCache.Data.FolderSize end; function TNamespace.ExplorerStyleAttributeStringList(CapitalLetters: Boolean): WideString; begin Result := ''; if Archive then Result := Result + STR_ARCHIVE; if Hidden then Result := Result + STR_HIDDEN; if ReadOnlyFile then Result := Result + STR_READONLY; if SystemFile then Result := Result + STR_SYSTEM; if Compressed then Result := Result + STR_COMPRESS; if not CapitalLetters then Result := WideLowerCase(Result) end; function TNamespace.GetArchive: Boolean; { GETTER: Does the file attributes contain Archive? } begin if IsUnicode then begin if not Assigned(FWin32FindDataW) then GetDataFromIDList; if Assigned(FWin32FindDataW) and FileSystem then Result := FWin32FindDataW^.dwFileAttributes and FILE_ATTRIBUTE_ARCHIVE <> 0 else Result := False; end else begin if not Assigned(FWin32FindDataA) then GetDataFromIDList; if Assigned(FWin32FindDataA) and FileSystem then Result := FWin32FindDataA^.dwFileAttributes and FILE_ATTRIBUTE_ARCHIVE <> 0 else Result := False; end end; function TNamespace.GetAttributesString: WideString; begin if FileSystem then Result := ExplorerStyleAttributeStringList(True) else Result := '' end; function TNamespace.GetBrowsable: Boolean; begin if not (scBrowsable in ShellCache.ShellCacheFlags) then begin if TestAttributesOf(SFGAO_BROWSABLE, False) then Include(FShellCache.Data.Attributes, caBrowsable); Include(FShellCache.ShellCacheFlags, scBrowsable); end; Result := caBrowsable in ShellCache.Data.Attributes end; function TNamespace.GetCanCopy: Boolean; begin if not (scCanCopy in ShellCache.ShellCacheFlags) then begin if TestAttributesOf(SFGAO_CANCOPY, False) then Include(FShellCache.Data.Attributes, caCanCopy); Include(FShellCache.ShellCacheFlags, scCanCopy); end; Result := caCanCopy in ShellCache.Data.Attributes end; function TNamespace.GetCanDelete: Boolean; { GETTER: Can we delete the namespace? } begin if not (scCanDelete in ShellCache.ShellCacheFlags) then begin if TestAttributesOf(SFGAO_CANDELETE, False) then Include(FShellCache.Data.Attributes, caCanDelete); Include(FShellCache.ShellCacheFlags, scCanDelete); end; Result := caCanDelete in ShellCache.Data.Attributes end; function TNamespace.GetCanLink: Boolean; begin if not (scCanLink in ShellCache.ShellCacheFlags) then begin if TestAttributesOf(SFGAO_CANLINK, False) then Include(FShellCache.Data.Attributes, caCanLink); Include(FShellCache.ShellCacheFlags, scCanLink); end; Result := caCanLink in ShellCache.Data.Attributes end; function TNamespace.GetCanMove: Boolean; begin if not (scCanMove in ShellCache.ShellCacheFlags) then begin if TestAttributesOf(SFGAO_CANMOVE, False) then Include(FShellCache.Data.Attributes, caCanMove); Include(FShellCache.ShellCacheFlags, scCanMove); end; Result := caCanMove in ShellCache.Data.Attributes end; function TNamespace.GetCanRename: Boolean; { GETTER: Can we Rename the namespace? } begin if not (scCanRename in ShellCache.ShellCacheFlags) then begin if TestAttributesOf(SFGAO_CANRENAME, False) then Include(FShellCache.Data.Attributes, caCanRename); Include(FShellCache.ShellCacheFlags, scCanRename); end; Result := caCanRename in ShellCache.Data.Attributes end; function TNamespace.GetCategoryCount: Integer; begin LoadCategoryInfo; Result := 0; end; function TNamespace.GetCLSID: TGUID; var DescriptionID: TSHDESCRIPTIONID; PersistFolder: IPersistFolder; begin Result := GUID_NULL; if Assigned(ParentShellFolder) then if Succeeded(SHGetDataFromIDList(ParentShellFolder, RelativePIDL, SHGDFIL_DESCRIPTIONID, @DescriptionID, SizeOf(TSHDESCRIPTIONID))) then Result := DescriptionID.Id; if IsEqualGUID(Result, GUID_NULL) then begin if Succeeded(ShellFolder.QueryInterface(IPersistFolder, PersistFolder)) then if not Succeeded(PersistFolder.GetClassID(Result)) then Result := GUID_NULL; end; end; function TNamespace.GetCompressed: Boolean; { GETTER: Does the file attributes contain Compressed? } begin if not (scCompressed in ShellCache.ShellCacheFlags) then begin if IsUnicode then begin if not Assigned(FWin32FindDataW) then GetDataFromIDList; if Assigned(FWin32FindDataW) and FileSystem then if FWin32FindDataW^.dwFileAttributes and FILE_ATTRIBUTE_COMPRESSED <> 0 then Include(FShellCache.Data.Attributes, caCompressed) end else begin if not Assigned(FWin32FindDataA) then GetDataFromIDList; if Assigned(FWin32FindDataA) and FileSystem then if FWin32FindDataA^.dwFileAttributes and FILE_ATTRIBUTE_COMPRESSED <> 0 then Include(FShellCache.Data.Attributes, caCompressed) end; Include(FShellCache.ShellCacheFlags, scCompressed); end; Result := caCompressed in ShellCache.Data.Attributes; end; function TNamespace.GetContextMenuInterface: IContextMenu; var PIDLArray: TRelativePIDLArray; begin if not Assigned(Result) then begin SetLength(PIDLArray, 1); PIDLArray[0] := RelativePIDL; Result := InternalGetContextMenuInterface(PIDLArray); end end; function TNamespace.GetContextMenu2Interface: IContextMenu2; var Found: Boolean; ContextMenu: IContextmenu; begin Found := False; ContextMenu := ContextMenuInterface; if Assigned(ContextMenu) then begin Found := ContextMenu.QueryInterface(IID_IContextMenu2, Pointer(Result)) <> E_NOINTERFACE; CurrentContextMenu2 := Result end; if not Found then Result := nil end; function TNamespace.GetContextMenu3Interface: IContextMenu3; var Found: Boolean; ContextMenu: IContextmenu; begin Found := False; ContextMenu := ContextMenuInterface; if Assigned(ContextMenu) then begin Found := ContextMenu.QueryInterface(IContextMenu3, Pointer(Result)) <> E_NOINTERFACE; CurrentContextMenu2 := Result end; if not Found then Result := nil end; function TNamespace.GetCreationTime: WideString; { GETTER: Creation time of the file. } begin if not (scCreationTime in ShellCache.ShellCacheFlags) then begin { Don't use Win32FindData cache, re-read the file times } GetFileTimes; if IsUnicode then begin if Assigned(FWin32FindDataW) and FileSystem then FShellCache.Data.CreationTime := ConvertTFileTimeToLocalStr(FWin32FindDataW^.ftCreationTime) else FShellCache.Data.CreationTime := ''; end else begin if Assigned(FWin32FindDataA) and FileSystem then FShellCache.Data.CreationTime := ConvertTFileTimeToLocalStr(FWin32FindDataA^.ftCreationTime) else FShellCache.Data.CreationTime := ''; end; Include(FShellCache.ShellCacheFlags, scCreationTime); end; Result := ShellCache.Data.CreationTime end; function TNamespace.GetCreationDateTime: TDateTime; begin Result := ConvertFileTimetoDateTime(CreationTimeRaw) end; function TNamespace.GetCreationTimeRaw: TFileTime; begin { Don't use Win32FindData cache, re-read the file times } GetFileTimes; if IsUnicode then begin if Assigned(FWin32FindDataW) then Result := FWin32FindDataW^.ftCreationTime else FillChar(Result, SizeOf(Result), #0); end else begin if Assigned(FWin32FindDataA) then Result := FWin32FindDataA^.ftCreationTime else FillChar(Result, SizeOf(Result), #0); end end; function TNamespace.GetParent: TNamespace; var P: PItemIDList; begin if not Assigned(FParent) then begin P := PIDLMgr.CopyPIDL(AbsolutePIDL); if PIDLMgr.IDCount(P) > 1 then FParent := TNamespace.Create(PIDLMgr.StripLastID(P), nil) else FParent := TNamespace.Create(nil, nil); Include(FStates, nsOwnsParent); end; Result := FParent; end; function TNamespace.GetThreadedDetailLoaded(ColumnIndex: Integer): Boolean; begin Result := False; EnsureDetailCache; if DetailsValidIndex(ColumnIndex) then Result := docThreadLoaded in ShellCache.Data.DetailsOfCache[ColumnIndex].Cached end; function TNamespace.GetThreadedDetailLoading(ColumnIndex: Integer): Boolean; begin Result := False; EnsureDetailCache; if DetailsValidIndex(ColumnIndex) then Result := docThreadLoading in ShellCache.Data.DetailsOfCache[ColumnIndex].Cached end; function TNamespace.ParentWnd: HWnd; begin Result := 0; if MP_UseModalDialogs then Result := GetActiveWindow end; procedure TNamespace.EnsureDetailCache; var i: Integer; TempCache: PDetailsOfCacheRec; begin if not (scDetailsOfCache in ShellCache.ShellCacheFlags) then begin SetLength(FShellCache.Data.DetailsOfCache, DetailsSupportedColumns); for i := 0 to Length(FShellCache.Data.DetailsOfCache) - 1 do begin TempCache := @ShellCache.Data.DetailsOfCache[i]; TempCache^.Cached := []; TempCache^.Caption := ''; TempCache^.States := []; end; Include(FShellCache.ShellCacheFlags, scDetailsOfCache); end; end; procedure TNamespace.ExecuteContextMenuVerbMultiPath(Verb: WideString; Namespaces: TNamespaceArray); var Menu: TCommonShellMultiParentContextMenu; Temp: TWinControl; begin Menu := TCommonShellMultiParentContextMenu.Create(nil); Temp := TWinControl.CreateParented(GetDesktopWindow); try Temp.Width := 0; Temp.Height := 0; Temp.Visible := True; Menu.ExecuteContextMenuVerb(Temp, Namespaces, Verb); Temp.Visible := False; finally Temp.Free; Menu.Free end end; procedure TNamespace.GetDataFromIDList; { Retrieves and caches the Data stored by the shell PIDL. } var Error: Boolean; begin if IsUnicode then begin if not Assigned(FWin32FindDataW) and not IsDesktop then begin if not (scInvalidIDListData in ShellCache.ShellCacheFlags) then begin Error := True; try if Assigned(ParentShellFolder) then begin GetMem(FWin32FindDataW, SizeOf(TWin32FindDataW)); FillChar(FWin32FindDataW^, SizeOf(FWin32FindDataW^), #0); { Children of the Desktop won't work if accessed from the Desktop } { ShellFolder, they must use the physical Desktop folder. } if Assigned(Parent) and (Parent.IsDesktop) and Assigned(PhysicalDesktopFolder) then begin Error := SHGetDataFromIDListW_MP(PhysicalDesktopFolder.ShellFolder, RelativePIDL, SHGDFIL_FINDDATA, FWin32FindDataW, SizeOf(TWin32FindDataW)) <> NOERROR; end else Error := SHGetDataFromIDListW_MP(ParentShellFolder, RelativePIDL, SHGDFIL_FINDDATA, FWin32FindDataW, SizeOf(TWin32FindDataW)) <> NOERROR; end finally if Error then begin if Assigned(FWin32FindDataW) then FreeMem(FWin32FindDataW, SizeOf(TWin32FindDataW)); FWin32FindDataW := nil; Include(FShellCache.ShellCacheFlags, scInvalidIDListData) end end; end end end else begin if not Assigned(FWin32FindDataA) and not IsDesktop then begin if not (scInvalidIDListData in ShellCache.ShellCacheFlags) then begin Error := True; try if Assigned(ParentShellFolder) then begin GetMem(FWin32FindDataA, SizeOf(TWin32FindDataA)); FillChar(FWin32FindDataA^, SizeOf(TWin32FindDataA), #0); { Children of the Desktop won't work if accessed from the Desktop } { ShellFolder, they must use the physical Desktop folder. } if Assigned(Parent) and (Parent.IsDesktop) and Assigned(PhysicalDesktopFolder) then begin Error := SHGetDataFromIDListA(PhysicalDesktopFolder.ShellFolder, RelativePIDL, SHGDFIL_FINDDATA, FWin32FindDataA, SizeOf(TWin32FindDataA)) <> NOERROR; end else Error := SHGetDataFromIDListA(ParentShellFolder, RelativePIDL, SHGDFIL_FINDDATA, FWin32FindDataA, SizeOf(TWin32FindDataA)) <> NOERROR; end finally if Error then begin if Assigned(FWin32FindDataA) then FreeMem(FWin32FindDataA, SizeOf(TWin32FindDataA)); FWin32FindDataA := nil; Include(FShellCache.ShellCacheFlags, scInvalidIDListData) end end; end end end end; function TNamespace.GetDataObjectInterface: IDataObject; begin Result := InternalGetDataObjectInterface(nil) end; function TNamespace.GetDescription: TObjectDescription; var DescriptionID: TSHDESCRIPTIONID; begin Result := odError; if Assigned(ParentShellFolder) then begin if Succeeded(SHGetDataFromIDList(ParentShellFolder, RelativePIDL, SHGDFIL_DESCRIPTIONID, @DescriptionID, SizeOf(TSHDESCRIPTIONID))) then Result := TObjectDescription(DescriptionID.dwDescriptionId) end end; function TNamespace.GetDetailsSupported: Boolean; begin { IShellDetails depends on the parent folder implementing the interface } if Assigned(Parent) then Result := Assigned(Parent.ShellFolder2) or Assigned(ParentShellDetailsInterface) else Result := False end; function TNamespace.GetDirectory: Boolean; { GETTER: Does the file attributes contain Directory? } begin if IsUnicode then begin if not Assigned(FWin32FindDataW) then GetDataFromIDList; if Assigned(FWin32FindDataW) and FileSystem then Result := FWin32FindDataW^.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0 else Result := False; end else begin if not Assigned(FWin32FindDataA) then GetDataFromIDList; if Assigned(FWin32FindDataA) and FileSystem then Result := FWin32FindDataA^.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0 else Result := False; end end; function TNamespace.GetDropTarget: Boolean; { GETTER: Can we drop another object on this namespace? Note the Desktop is } { handled as a special case. The IDropTarget is mapped to the physical folder } { location in the DropTargetInterface property. } begin Result := TestAttributesOf(SFGAO_DROPTARGET, False) or PIDLMgr.IsDesktopFolder(RelativePIDL); end; function TNamespace.GetDropTargetInterface: IDropTarget; var Found: Boolean; begin if not Assigned(FDropTargetInterface) then begin Found := False; if Assigned(ParentShellFolder) then begin Found := ParentShellFolder.GetUIObjectOf(ParentWnd, 1, FRelativePIDL, IID_IDropTarget, nil, Pointer(FDropTargetInterface)) = NOERROR; end; if not Found and IsDesktop then FDropTargetInterface := PhysicalDesktopFolder.DropTargetInterface; end; Result := FDropTargetInterface end; function TNamespace.GetExtension: WideString; begin Result := WideExtractFileExt(NameForParsingInFolder); end; function TNamespace.GetExtractImage: TExtractImage; begin if not Assigned(FExtractImage) then begin FExtractImage := TExtractImage.Create; FExtractImage.Owner := Self end; Result := FExtractImage end; function TNamespace.GetExtractIconAInterface: IExtractIcon; var Found: Boolean; begin if Assigned(ParentShellFolder) then begin Found := Succeeded(ParentShellFolder.GetUIObjectOf(ParentWnd, 1, FRelativePIDL, IExtractIconA, nil, Pointer(Result))); if not Found and Assigned(ShellFolder) then Found := Succeeded(ShellFolder.CreateViewObject(ParentWnd, IExtractIconA, Pointer(Result))); if not Found then Result := nil end end; function TNamespace.GetExtractIconWInterface: IExtractIconW; var Found: Boolean; begin if Assigned(ParentShellFolder) then begin Found := Succeeded(ParentShellFolder.GetUIObjectOf(ParentWnd, 1, FRelativePIDL, IExtractIconW, nil, Pointer(Result))); if not Found and Assigned(ShellFolder) then Found := Succeeded(ShellFolder.CreateViewObject(ParentWnd, IExtractIconW, Pointer(Result))); if not Found then Result := nil end end; function TNamespace.GetFileName: WideString; { GETTER: FileName from the file system (FindFirst) } begin if IsUnicode then begin if not Assigned(FWin32FindDataW) then GetDataFromIDList; if Assigned(FWin32FindDataW) and FileSystem then Result := FWin32FindDataW^.cFileName else Result := ''; end else begin if not Assigned(FWin32FindDataA) then GetDataFromIDList; if Assigned(FWin32FindDataA) and FileSystem then Result := FWin32FindDataA^.cFileName else Result := ''; end end; function TNamespace.GetFileSysAncestor: Boolean; // Only works reliablely on Win2k and above begin if not (scFileSysAncestor in ShellCache.ShellCacheFlags) then begin if TestAttributesOf(SFGAO_FILESYSANCESTOR, False) then Include(FShellCache.Data.Attributes, caFileSysAncestor); Include(FShellCache.ShellCacheFlags, scFileSysAncestor); end; Result := caFileSysAncestor in ShellCache.Data.Attributes end; function TNamespace.GetFileSystem: Boolean; { GETTER: Is the namespace part of the physical file system? } begin if not (scFileSystem in ShellCache.ShellCacheFlags) then begin if TestAttributesOf(SFGAO_FILESYSTEM, False) then Include(FShellCache.Data.Attributes, caFileSystem); Include(FShellCache.ShellCacheFlags, scFileSystem); end; Result := caFileSystem in ShellCache.Data.Attributes end; procedure TNamespace.GetFileTimes; var Handle: THandle; FileDataA: TWin32FindData; FileDataW: TWin32FindDataW; S: string; begin if not (scFileTimes in ShellCache.ShellCacheFlags) then begin if IsUnicode then begin if not Assigned(FWin32FindDataW) then GetDataFromIDList; if FileSystem and Assigned(FWin32FindDataW) then begin FillChar(FileDataW, SizeOf(FileDataW), #0); Handle := FindFirstFileW_MP(PWideChar( NameParseAddress), FileDataW); if Handle <> INVALID_HANDLE_VALUE then begin Windows.FindClose(Handle); // There is no FindCloseW FWin32FindDataW.ftLastAccessTime := FileDataW.ftLastAccessTime; FWin32FindDataW.ftCreationTime := FileDataW.ftCreationTime; FWin32FindDataW.ftLastWriteTime := FileDataW.ftLastWriteTime end end; end else begin if not Assigned(FWin32FindDataA) then GetDataFromIDList; if FileSystem and Assigned(FWin32FindDataA) then begin FillChar(FileDataA, SizeOf(FileDataA), #0); S := NameParseAddress; Handle := FindFirstFileA(PChar( S), FileDataA); if Handle <> INVALID_HANDLE_VALUE then begin Windows.FindClose(Handle); // There is no ASCI and Wide version FWin32FindDataA.ftLastAccessTime := FileDataA.ftLastAccessTime; FWin32FindDataA.ftCreationTime := FileDataA.ftCreationTime; FWin32FindDataA.ftLastWriteTime := FileDataA.ftLastWriteTime end end; end; Include(FShellCache.ShellCacheFlags, scFileTimes) end; end; function TNamespace.GetFileType: WideString; // File type string shown in column 3 of Explorer Listview begin if not (scFileType in ShellCache.ShellCacheFlags) then begin if not Assigned(FSHGetFileInfoRec) then GetSHFileInfo; if Assigned(FSHGetFileInfoRec) then begin FShellCache.Data.FileType := FSHGetFileInfoRec^.FileType; { NT only half-assed supports the SHGetFileInfo...only if the ext is } { associated with a program. So we build it ourselves } if FShellCache.Data.FileType = '' then FShellCache.Data.FileType := WideUpperCase(WideExtractFileExt(NameForParsing)) + STR_FILE; end else FShellCache.Data.FileType := ''; Include(FShellCache.ShellCacheFlags, scFileType); end; Result := ShellCache.Data.FileType end; function TNamespace.GetFolder: Boolean; // Ask the Folder if it is a Folder, as opposed to files. Folders can contain // other objects. begin if not (scFolder in ShellCache.ShellCacheFlags) then begin if TestAttributesOf(SFGAO_FOLDER, False) then Include(FShellCache.Data.Attributes, caFolder); Include(FShellCache.ShellCacheFlags, scFolder); end; Result := caFolder in ShellCache.Data.Attributes; end; function TNamespace.GetFreePIDLOnDestroy: Boolean; begin Result := nsFreePIDLOnDestroy in States end; function TNamespace.GetGhosted: Boolean; // Ask the Folder if it is a ghosted file object. Partially encapsulates the // IShellFolder.GetAttributesOf function. begin if not (scGhosted in ShellCache.ShellCacheFlags) then begin if TestAttributesOf(SFGAO_GHOSTED, False) then Include(FShellCache.Data.Attributes, caGhosted); Include(FShellCache.ShellCacheFlags, scGhosted); end; Result := caGhosted in ShellCache.Data.Attributes end; function TNamespace.GetHasPropSheet: Boolean; begin Result := TestAttributesOf(SFGAO_HASPROPSHEET, False); end; function TNamespace.GetHasSubFolder: Boolean; begin Result := TestAttributesOf(SFGAO_HASSUBFOLDER, False); end; function TNamespace.GetHidden: Boolean; begin if IsUnicode then begin if not Assigned(FWin32FindDataW) then GetDataFromIDList; if Assigned(FWin32FindDataW) and FileSystem then Result := FWin32FindDataW^.dwFileAttributes and FILE_ATTRIBUTE_HIDDEN <> 0 else Result := False; end else begin if not Assigned(FWin32FindDataA) then GetDataFromIDList; if Assigned(FWin32FindDataA) and FileSystem then Result := FWin32FindDataA^.dwFileAttributes and FILE_ATTRIBUTE_HIDDEN <> 0 else Result := False; end end; function TNamespace.GetIconIndexChanged: Boolean; begin Result := nsIconIndexChanged in States end; function TNamespace.GetIconIndex(OpenIcon: Boolean; IconSize: TIconSize; ForceLoad: Boolean = True): integer; { Retrieve the Icon Index either selected or not selected (open folder or } { closed folder) } function GetIconByIShellIcon(AnOpenIcon: Boolean; Size: TIconSize; var Index: integer): Boolean; var Flags: Longword; begin Result := False; if Assigned(ShellIconInterface) then begin Flags := 0; if Size = icLarge then Flags := GIL_FORSHELL; if AnOpenIcon then Flags := GIL_OPENICON or Flags; Result := ShellIconInterface.GetIconOf(RelativePIDL, Flags, Index) = NOERROR end end; procedure GetIconBySHGetFileInfo(AnOpenIcon: Boolean; Size: TIconSize; var Index: Integer); { A little undocumented trick. If you use the SHGFI_USEFILEATTRIBUTES flags } { the SHGetFileInfo function does not fully access the object and is much } { faster. } { UPDATE: Unfortunatly this does not work well in Win98 :^( } var Flags: integer; InfoA: TSHFileInfoA; InfoW: TSHFileInfoW; begin Flags := SHGFI_PIDL or SHGFI_SYSICONINDEX or SHGFI_SHELLICONSIZE; if IconSize = icLarge then Flags := Flags or SHGFI_LARGEICON else Flags := Flags or SHGFI_SMALLICON; if AnOpenIcon then Flags := Flags or SHGFI_OPENICON; if IsUnicode then begin FillChar(InfoW, SizeOf(InfoW), #0); if SHGetFileInfoW_MP(PWideChar(AbsolutePIDL), 0, InfoW, SizeOf(InfoW), Flags) <> 0 then Index := InfoW.iIcon else Index := 0 end else begin FillChar(InfoA, SizeOf(InfoA), #0); if SHGetFileInfoA(PChar(AbsolutePIDL), 0, InfoA, SizeOf(InfoA), Flags) <> 0 then Index := InfoA.iIcon else Index := 0 end end; function GetIcon(IsOpen: Boolean; IconSize: TIconSize): integer; begin if not GetIconByIShellIcon(IsOpen, IconSize, Result) then GetIconBySHGetFileInfo(IsOpen, IconSize, Result); end; begin if not OpenIcon then begin if not (scSmallIcon in ShellCache.ShellCacheFlags) or ForceLoad then begin FShellCache.Data.SmallIcon := GetIcon(False, icSmall); Include(FShellCache.ShellCacheFlags, scSmallIcon); end; Result := ShellCache.Data.SmallIcon; end else begin if not (scSmallOpenIcon in ShellCache.ShellCacheFlags) or ForceLoad then begin { Some Control panel icons return 0 for open but have icons for not open } { and it looks bad to show the default icon when the item is selected. } { In NT4 some ControlPanel icons are the Mouse icons when selected! } if Assigned(Parent) and Parent.IsControlPanel then FShellCache.Data.SmallOpenIcon := GetIcon(False, icSmall) else begin FShellCache.Data.SmallOpenIcon := GetIcon(True, icSmall); { If it is 0 then try the normal icon } if FShellCache.Data.SmallOpenIcon = 0 then FShellCache.Data.SmallOpenIcon := GetIcon(False, icSmall) end; Include(FShellCache.ShellCacheFlags, scSmallOpenIcon) end; Result := ShellCache.Data.SmallOpenIcon; end; end; function TNamespace.GetInfoTip: WideString; { Retrieves the text from the IInfoTip interface in Win2k. } var Buffer: PWideChar; begin Result := ''; if Assigned(QueryInfoInterface) then begin if QueryInfoInterface.GetInfoTip(0, Buffer) = S_OK then begin Result := Buffer; PIDLMgr.FreeOLEStr(Buffer); end; end; end; function TNamespace.GetLastAccessTime: WideString; { GETTER: Last Access time of the file. } begin if not (scLastAccessTime in ShellCache.ShellCacheFlags) then begin { Don't use Win32FindData cache, re-read the file times } GetFileTimes; if IsUnicode then begin if Assigned(FWin32FindDataW) and FileSystem then FShellCache.Data.LastAccessTime := ConvertTFileTimeToLocalStr(FWin32FindDataW^.ftLastAccessTime) else FShellCache.Data.LastAccessTime := ''; end else begin if Assigned(FWin32FindDataA) and FileSystem then FShellCache.Data.LastAccessTime := ConvertTFileTimeToLocalStr(FWin32FindDataA^.ftLastAccessTime) else FShellCache.Data.LastAccessTime := ''; end; Include(FShellCache.ShellCacheFlags, scLastAccessTime); end; Result := FShellCache.Data.LastAccessTime end; function TNamespace.GetLastAccessDateTime: TDateTime; begin Result := ConvertFileTimetoDateTime(LastAccessTimeRaw) end; function TNamespace.GetLastAccessTimeRaw: TFileTime; begin { Don't use Win32FindData cache, re-read the file times } GetFileTimes; if IsUnicode then begin if Assigned(FWin32FindDataW) then Result := FWin32FindDataW^.ftLastAccessTime else FillChar(Result, SizeOf(Result), #0); end else begin if Assigned(FWin32FindDataA) then Result := FWin32FindDataA^.ftLastAccessTime else FillChar(Result, SizeOf(Result), #0); end end; function TNamespace.GetLastWriteTime: WideString; { GETTER: Last write time for the file. } begin if not (scLastWriteTime in ShellCache.ShellCacheFlags) then begin { Don't use Win32FindData cache, re-read the file times } GetFileTimes; if IsUnicode then begin if Assigned(FWin32FindDataW) and FileSystem then FShellCache.Data.LastWriteTime := ConvertTFileTimeToLocalStr(FWin32FindDataW^.ftLastWriteTime) else FShellCache.Data.LastWriteTime := ''; end else begin if Assigned(FWin32FindDataA) and FileSystem then FShellCache.Data.LastWriteTime := ConvertTFileTimeToLocalStr(FWin32FindDataA^.ftLastWriteTime) else FShellCache.Data.LastWriteTime := ''; end; Include(FShellCache.ShellCacheFlags, scLastWriteTime); end; Result := FShellCache.Data.LastWriteTime end; function TNamespace.GetLastWriteDateTime: TDateTime; begin Result := ConvertFileTimetoDateTime(LastWriteTimeRaw) end; function TNamespace.GetLastWriteTimeRaw: TFileTime; { GETTER: Last Write time for the file in raw TFileTime format. } begin { Don't use Win32FindData cache, re-read the file times } GetFileTimes; if IsUnicode then begin if Assigned(FWin32FindDataW) then Result := FWin32FindDataW^.ftLastWriteTime else FillChar(Result, SizeOf(Result), #0); end else begin if Assigned(FWin32FindDataA) then Result := FWin32FindDataA^.ftLastWriteTime else FillChar(Result, SizeOf(Result), #0); end end; function TNamespace.GetLink: Boolean; begin if not (scLink in ShellCache.ShellCacheFlags) then begin if TestAttributesOf(SFGAO_LINK, False) then Include(FShellCache.Data.Attributes, caLink); Include(FShellCache.ShellCacheFlags, scLink); end; Result := caLink in ShellCache.Data.Attributes end; function TNamespace.GetNameAddressbar: WideString; begin Result := DisplayNameOf(SHGDN_FORADDRESSBAR or SHGDN_NORMAL) end; function TNamespace.GetNameAddressbarInFolder: WideString; begin Result := DisplayNameOf(SHGDN_INFOLDER or SHGDN_FORADDRESSBAR) end; function TNamespace.GetNameForEditing: WideString; begin Result := DisplayNameOf(SHGDN_FOREDITING) end; function TNamespace.GetNameForEditingInFolder: WideString; begin Result := DisplayNameOf(SHGDN_FOREDITING or SHGDN_INFOLDER) end; function TNamespace.GetNameForParsing: WideString; begin // Early versions of Windows returned "Desktop" instead of the full path if IsDesktop then Result := PhysicalDesktopFolder.NameForParsing else Result := DisplayNameOf(SHGDN_FORPARSING or SHGDN_NORMAL) end; function TNamespace.GetNameForParsingInFolder: WideString; begin // Early versions of Windows returned "Desktop" instead of the full path if IsDesktop then Result := PhysicalDesktopFolder.NameForParsingInFolder else Result := DisplayNameOf(SHGDN_INFOLDER or SHGDN_FORPARSING) end; function TNamespace.GetNameInFolder: WideString; begin if not (scInFolderName in ShellCache.ShellCacheFlags) then begin FShellCache.Data.InFolderName := DisplayNameOf(SHGDN_INFOLDER); Include(FShellCache.ShellCacheFlags, scInFolderName) end; Result := FShellCache.Data.InFolderName end; function TNamespace.GetNameNormal: WideString; begin if not (scNormalName in ShellCache.ShellCacheFlags) then begin FShellCache.Data.NormalName := DisplayNameOf(SHGDN_NORMAL); Include(FShellCache.ShellCacheFlags, scNormalName) end; Result := FShellCache.Data.NormalName end; function TNamespace.GetNameParseAddress: WideString; begin if not (scParsedName in ShellCache.ShellCacheFlags) then begin FShellCache.Data.ParsedName := DisplayNameOf(SHGDN_FORADDRESSBAR or SHGDN_FORPARSING); Include(FShellCache.ShellCacheFlags, scParsedName) end; Result := FShellCache.Data.ParsedName end; function TNamespace.GetNameParseAddressInFolder: WideString; begin Result := DisplayNameOf(SHGDN_FORADDRESSBAR or SHGDN_FORPARSING or SHGDN_INFOLDER) end; function TNamespace.GetNewContent: Boolean; { GETTER: Does this namespace contain new content? } begin Result := TestAttributesOf(SFGAO_NEWCONTENT, False); end; function TNamespace.GetNonEnumerated: Boolean; { GETTER: Is this namespace able to be enumerated? } begin Result := TestAttributesOf(SFGAO_NONENUMERATED, False); end; function TNamespace.GetNormal: Boolean; { GETTER: Does the file attributes contain Normal? } begin if IsUnicode then begin if not Assigned(FWin32FindDataW) then GetDataFromIDList; if Assigned(FWin32FindDataW) and FileSystem then Result := FWin32FindDataW^.dwFileAttributes and FILE_ATTRIBUTE_NORMAL <> 0 else Result := False; end else begin if not Assigned(FWin32FindDataA) then GetDataFromIDList; if Assigned(FWin32FindDataA) and FileSystem then Result := FWin32FindDataA^.dwFileAttributes and FILE_ATTRIBUTE_NORMAL <> 0 else Result := False; end end; function TNamespace.GetOffLine: Boolean; { GETTER: Does the file attributes contain OffLine? } begin if IsUnicode then begin if not Assigned(FWin32FindDataW) then GetDataFromIDList; if Assigned(FWin32FindDataW) and FileSystem then Result := FWin32FindDataW^.dwFileAttributes and FILE_ATTRIBUTE_OFFLINE <> 0 else Result := False; end else begin if not Assigned(FWin32FindDataA) then GetDataFromIDList; if Assigned(FWin32FindDataA) and FileSystem then Result := FWin32FindDataA^.dwFileAttributes and FILE_ATTRIBUTE_OFFLINE <> 0 else Result := False; end end; function TNamespace.GetImage: TBitmap; begin Result := FImage; end; procedure TNamespace.InvalidateDetailsOfCache(FlushStrings: Boolean); var i: Integer; begin for i := 0 to Length( ShellCache.Data.DetailsOfCache) - 1 do begin ShellCache.Data.DetailsOfCache[i].Cached := []; if FlushStrings then ShellCache.Data.DetailsOfCache[i].Caption := '' end; FShellCache.ShellCacheFlags := ShellCache.ShellCacheFlags - [scDetailsOfCache]; FShellCache.ShellCacheFlags := ShellCache.ShellCacheFlags - [scInFolderName]; end; procedure TNamespace.InvalidateThumbImage; begin FreeAndNIL(FImage); Exclude(FStates, nsThreadedImageLoaded); Exclude(FStates, nsThreadedImageLoading); end; function TNamespace.SubFoldersEx(Flags: Longword = SHCONTF_FOLDERS): Boolean; begin Result := InternalSubItems(Flags) end; function TNamespace.SubItemsEx(Flags: Longword = SHCONTF_NONFOLDERS): Boolean; begin Result := InternalSubItems(Flags) end; function TNamespace.GetOverlayIconIndex: Integer; begin if Assigned(Parent) then begin if Assigned(Parent.ShellIconOverlayInterface) then begin if FShellCache.Data.OverlayIconIndex < 0 then begin if Parent.ShellIconOverlayInterface.GetOverlayIconIndex(FRelativePIDL, FShellCache.Data.OverlayIconIndex) <> S_OK then FShellCache.Data.OverlayIconIndex := -1; end end end; Result := FShellCache.Data.OverlayIconIndex end; function TNamespace.GetOverlayIndex: Integer; begin if Assigned(Parent) then begin if not (scOverlayIndex in FShellCache.ShellCacheFlags) then begin if Assigned(Parent.ShellIconOverlayInterface) then begin if FShellCache.Data.OverlayIndex < 0 then begin if Parent.ShellIconOverlayInterface.GetOverlayIndex(FRelativePIDL, FShellCache.Data.OverlayIndex) <> S_OK then begin if MP_UseSpecialReparsePointOverlay and IsUnicode and not IsWinNT4 and ReparsePoint then FShellCache.Data.OverlayIndex := 4 else FShellCache.Data.OverlayIndex := -1; end end end; Include(FShellCache.ShellCacheFlags, scOverlayIndex) end end; Result := FShellCache.Data.OverlayIndex; end; function TNamespace.GetCanMoniker: Boolean; begin Result := TestAttributesOf(SFGAO_CANMONIKER, False) end; function TNamespace.GetEncrypted: Boolean; begin Result := TestAttributesOf(SFGAO_ENCRYPTED, False) end; function TNamespace.GetHasStorage: Boolean; begin Result := TestAttributesOf(SFGAO_HASSTORAGE, False) end; function TNamespace.GetIsSlow: Boolean; begin Result := TestAttributesOf(SFGAO_ISSLOW, False) end; function TNamespace.GetStorage: Boolean; begin Result := TestAttributesOf(SFGAO_STORAGE, False) end; function TNamespace.GetStorageAncestor: Boolean; begin Result := TestAttributesOf(SFGAO_STORAGEANCESTOR, False) end; function TNamespace.GetStream: Boolean; begin Result := TestAttributesOf(SFGAO_STREAM, False) end; function TNamespace.GetParentShellDetailsInterface: IVETShellDetails; begin { This forces the Parent to be created if necessary } if Assigned(ParentShellFolder) then Result := Parent.ShellDetailsInterface else Result := ShellDetailsInterface end; function TNamespace.GetParentShellFolder: IShellFolder; //var // P: PItemIDList; begin Result := Parent.ShellFolder (* Result := nil; // 08.31.02 // Going to try to allow the Parent to persist if the namespace creates it itself. // This is called a LOT more than I thought expecially for the ExplorerListview if Assigned(Parent) then begin Result := Parent.ShellFolder end else if not IsDesktop then begin if Assigned(Parent) then FreeAndNil(FParent); P := PIDLMgr.CopyPIDL(AbsolutePIDL); FParent := TNamespace.Create(PIDLMgr.StripLastID(P), nil); if Assigned(FParent) then begin Result := FParent.ShellFolder; { Since we created the parent we own it in case we have to destroy it in } { our destructor. } Include(FStates, nsOwnsParent); end end else Result := ShellFolder *) end; function TNamespace.GetParentShellFolder2: IShellFolder2; begin { This flag keeps us from constantly trying to get FShellFolder2 if it is not } { supported by the namespace. } { This forces the Parent to be created if necessary } if Assigned(ParentShellFolder) then Result := Parent.ShellFolder2 else Result := ShellFolder2 end; function TNamespace.GetQueryInfoInterface: IQueryInfo; var Found: Boolean; begin if not Assigned(FQueryInfoInterface) then begin Found := False; if Assigned(ParentShellFolder) then begin Found := ParentShellFolder.GetUIObjectOf(ParentWnd, 1, FRelativePIDL, IQueryInfo, nil, Pointer(FQueryInfoInterface)) = NOERROR; end; if not Found and Assigned(ShellFolder) then begin Found := ShellFolder.CreateViewObject(ParentWnd, IQueryInfo, Pointer(FQueryInfoInterface)) = NOERROR; end; if not Found and IsDesktop then FQueryInfoInterface := PhysicalDesktopFolder.QueryInfoInterface; end; Result := FQueryInfoInterface end; function TNamespace.GetReadOnly: Boolean; { GETTER: Is this namespace ReadOnly? } begin Result := TestAttributesOf(SFGAO_READONLY, False); end; function TNamespace.GetReadOnlyFile: Boolean; { GETTER: Does the file attributes contain ReadOnly? } begin if IsUnicode then begin if not Assigned(FWin32FindDataW) then GetDataFromIDList; if Assigned(FWin32FindDataW) and FileSystem then Result := FWin32FindDataW^.dwFileAttributes and FILE_ATTRIBUTE_READONLY <> 0 else Result := False; end else begin if not Assigned(FWin32FindDataA) then GetDataFromIDList; if Assigned(FWin32FindDataA) and FileSystem then Result := FWin32FindDataA^.dwFileAttributes and FILE_ATTRIBUTE_READONLY <> 0 else Result := False; end end; function TNamespace.GetReparsePoint: Boolean; { GETTER: Does the file attributes contain ReadOnly? } begin if IsUnicode then begin if not Assigned(FWin32FindDataW) then GetDataFromIDList; if Assigned(FWin32FindDataW) and FileSystem then Result := FWin32FindDataW^.dwFileAttributes and FILE_ATTRIBUTE_REPARSE_POINT <> 0 else Result := False; end else begin if not Assigned(FWin32FindDataA) then GetDataFromIDList; if Assigned(FWin32FindDataA) and FileSystem then Result := FWin32FindDataA^.dwFileAttributes and FILE_ATTRIBUTE_REPARSE_POINT <> 0 else Result := False; end end; function TNamespace.GetRemovable: Boolean; { GETTER: Is this a removeable object? } begin Result := TestAttributesOf(SFGAO_REMOVABLE, False); end; function TNamespace.GetShellDetailsInterface: IVETShellDetails; var Found: Boolean; begin { This flag keeps us from constantly trying to get IShellDetails if it is not } { supported by the namespace. } if (nsShellDetailsSupported in States) and not Assigned(FShellDetailsInterface) then begin Found := False; if not Found and Assigned(ShellFolder) then Found := ShellFolder.CreateViewObject(ParentWnd, IID_IShellDetails, Pointer(FShellDetailsInterface)) = NOERROR; if not Found and Assigned(ParentShellFolder) then Found := ParentShellFolder.GetUIObjectOf(ParentWnd, 1, FRelativePIDL, IID_IShellDetails, nil, Pointer(FShellDetailsInterface)) = NOERROR; if Found then Include(FStates, nsShellDetailsSupported) else begin Exclude(FStates, nsShellDetailsSupported); FShellDetailsInterface := nil end end; Result := FShellDetailsInterface; end; function TNamespace.GetShellIconInterface: IShellIcon; var Found: Boolean; begin if not Assigned(FShellIconInterface) then begin Found := False; if Assigned(ParentShellFolder) then Found := ParentShellFolder.QueryInterface(IID_IShellIcon, Pointer(FShellIconInterface)) <> E_NOINTERFACE; if not Found then FShellIconInterface := nil end; Result := FShellIconInterface end; function TNamespace.GetShellFolder: IShellFolder; var P: PItemIDList; ParentFolder, Desktop: IShellFolder; begin if not Assigned(FShellFolder) then begin SHGetDesktopFolder(Desktop); if PIDLMgr.IDCount(AbsolutePIDL) > 1 then begin P := PIDLMgr.StripLastID(PIDLMgr.CopyPIDL(AbsolutePIDL)); Desktop.BindToObject(P, nil, IID_IShellFolder, Pointer(ParentFolder)); PIDLMgr.FreePIDL(P) end else ParentFolder := Desktop; if Assigned(ParentFolder) then begin if IsDesktop or not Folder then FShellFolder := ParentFolder else begin if not Succeeded(ParentFolder.BindToObject(FRelativePIDL, nil, IID_IShellFolder, Pointer(FShellFolder))) then FShellFolder := nil end end else FShellFolder := nil end; Result := FShellFolder end; function TNamespace.GetShellFolder2: IShellFolder2; begin { This flag keeps us from constantly trying to get FShellFolder2 if it is not } { supported by the namespace. } if (nsShellFolder2Supported in States) and not Assigned(FShellFolder2) then begin if Assigned(ShellFolder) then if ShellFolder.QueryInterface(IID_IShellFolder2, Pointer(FShellFolder2)) = E_NOINTERFACE then begin FShellFolder2 := nil; Exclude(FStates, nsShellFolder2Supported) end else Include(FStates, nsShellFolder2Supported) end; Result := FShellFolder2; end; function TNamespace.GetShellLink: TVirtualShellLink; begin if Link then begin if not Assigned(FShellLink) then FShellLink := TVirtualShellLink.Create(nil); FShellLink.ReadLink(NameParseAddress); end; Result := FShellLink end; function TNamespace.GetSizeOfFile: WideString; { GETTER: Get the size of the file in string format} begin if not (scFileSize in ShellCache.ShellCacheFlags) then begin if not Folder then begin FShellCache.Data.FileSize := Format('%0.0n', [SizeOfFileInt64 + 0.0]); // FShellCache.Data.FileSize := AddCommas(WideIntToStr(SizeOfFileInt64)); Include(FShellCache.ShellCacheFlags, scFileSize); end else FShellCache.Data.FileSize := '' end; Result := ShellCache.Data.FileSize end; function TNamespace.GetSizeOfFileDiskUsage: WideString; var Size, BytesPerCluster: Int64; Drive: string; DriveW: WideString; SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters, i : DWORD; ValidData: Boolean; begin if not Folder then begin Size := SizeOfFileInt64; DriveW := WideExtractFileDrive(Self.NameForParsing) + '\'; Drive := DriveW; if WideDirectoryExists(Drive) then begin ValidData := GetDiskFreeSpaceMP(PWideChar( DriveW), SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters); if ValidData then begin BytesPerCluster := Int64(SectorsPerCluster) * Int64(BytesPerSector); if BytesPerCluster <> 0 then begin { In the *rare* instance where the actual size is equal to multiple of } { the sector size don't do the math :^) } if Size mod BytesPerCluster <> 0 then i := 1 else i := 0; Result := Format('%0.0n', [Int64(BytesPerCluster) *(Size div Int64(BytesPerCluster) + i) + 0.0]) end else Result := SizeOfFile end else Result := SizeOfFile end else Result := SizeOfFile end; end; function TNamespace.GetSizeOfFileInt64: Int64; var H: THandle; FindDataW: TWin32FindDataW; FindDataA: TWin32FindDataA; { GETTER: Get the file size in bytes. } // The PIDL does not store the file size for > 4G files, need to use FindFirstFile begin if not (scFileSizeInt64 in ShellCache.ShellCacheFlags) then begin if FileSystem then begin if IsUnicode then begin H := FindFirstFileW_MP(PWideChar(NameForParsing), FindDataW); if H <> INVALID_HANDLE_VALUE then begin Windows.FindClose(H); FShellCache.Data.FileSizeInt64 := FindDataW.nFileSizeLow; if FShellCache.Data.FileSizeInt64 < 0 then FShellCache.Data.FileSizeInt64 := FShellCache.Data.FileSizeInt64 + 4294967296; if FindDataW.nFileSizeHigh > 0 then FShellCache.Data.FileSizeInt64 := FShellCache.Data.FileSizeInt64 + (FindDataW.nFileSizeHigh * 4294967296) end end else begin H := FindFirstFileA(PChar(string(NameForParsing)), FindDataA); if H <> INVALID_HANDLE_VALUE then begin Windows.FindClose(H); FShellCache.Data.FileSizeInt64 := FindDataA.nFileSizeLow; if FShellCache.Data.FileSizeInt64 < 0 then FShellCache.Data.FileSizeInt64 := FShellCache.Data.FileSizeInt64 + 4294967296; if FindDataA.nFileSizeHigh > 0 then FShellCache.Data.FileSizeInt64 := FShellCache.Data.FileSizeInt64 + (FindDataA.nFileSizeHigh * 4294967296) end end end; Include(FShellCache.ShellCacheFlags, scFileSizeInt64) end; Result := FShellCache.Data.FileSizeInt64 end; function TNamespace.GetSizeOfFileKB: WideString; { GETTER: Get the file size in Explorer KiloByte format. } begin if not (scFileSizeKB in ShellCache.ShellCacheFlags) then begin if not Folder then begin if SizeOfFileInt64 > 0 then begin FShellCache.Data.FileSizeKB := Format('%0.0n '+ 'KB', [SizeOfFileInt64/1024]); if (FShellCache.Data.FileSizeKB = STR_ZERO_KB) then FShellCache.Data.FileSizeKB := STR_ONE_KB; end else FShellCache.Data.FileSizeKB := STR_ONE_KB; Include(FShellCache.ShellCacheFlags, scFileSizeKB) end else FShellCache.Data.FileSizeKB := ''; end; Result := FShellCache.Data.FileSizeKB; end; function TNamespace.GetSparseFile: Boolean; { GETTER: Does the file attributes contain ReadOnly? } begin if IsUnicode then begin if not Assigned(FWin32FindDataW) then GetDataFromIDList; if Assigned(FWin32FindDataW) and FileSystem then Result := FWin32FindDataW^.dwFileAttributes and FILE_ATTRIBUTE_SPARSE_FILE <> 0 else Result := False; end else begin if not Assigned(FWin32FindDataA) then GetDataFromIDList; if Assigned(FWin32FindDataA) and FileSystem then Result := FWin32FindDataA^.dwFileAttributes and FILE_ATTRIBUTE_SPARSE_FILE <> 0 else Result := False; end end; function TNamespace.GetShare: Boolean; begin Result := TestAttributesOf(SFGAO_SHARE, False); end; procedure TNamespace.GetSHFileInfo; { Retrieves and caches the some information about the namespace with } { ShGetFileInfo. } var InfoA: TSHFileInfoA; InfoW: TSHFileInfoW; begin if not Assigned(FSHGetFileInfoRec) then begin if IsUnicode then begin GetMem(FSHGetFileInfoRec, SizeOf(FSHGetFileInfoRec^)); Initialize(FSHGetFileInfoRec^.FileType); if Assigned(FSHGetFileInfoRec) then begin SHGetFileInfoW_MP(PWideChar(AbsolutePIDL), 0, InfoW, SizeOf(InfoW), SHGFI_TYPENAME or SHGFI_PIDL); FSHGetFileInfoRec^.FileType := InfoW.szTypeName; { NT only half-assed supports the SHGetFileInfo...only if the ext is } { associated with a program. So we build it ourselves } if FSHGetFileInfoRec^.FileType = '' then FSHGetFileInfoRec^.FileType := WideUpperCase(WideExtractFileExt(NameForParsing)) + STR_FILE; end end else begin GetMem(FSHGetFileInfoRec, SizeOf(FSHGetFileInfoRec^)); Initialize(FSHGetFileInfoRec^.FileType); if Assigned(FSHGetFileInfoRec) then begin SHGetFileInfoA(PChar(AbsolutePIDL), 0, InfoA, SizeOf(InfoA), SHGFI_TYPENAME or SHGFI_PIDL); FSHGetFileInfoRec^.FileType := InfoA.szTypeName; { NT only half-assed supports the SHGetFileInfo...only if the ext is } { associated with a program. So we build it ourselves } if FSHGetFileInfoRec^.FileType = '' then FSHGetFileInfoRec^.FileType := WideUpperCase(WideExtractFileExt(NameForParsing)) + STR_FILE; end end; end; end; function TNamespace.GetShortFileName: WideString; { GETTER: Get the 8:3 short file name (DOS) } begin if IsUnicode then begin if not Assigned(FWin32FindDataW) then GetDataFromIDList; if Assigned(FWin32FindDataW) and FileSystem then begin Result := FWin32FindDataW^.cAlternateFileName; if Result = '' then Result := WideUpperCase(FWin32FindDataW^.CFileName) end else Result := ''; end else begin if not Assigned(FWin32FindDataA) then GetDataFromIDList; if Assigned(FWin32FindDataA) and FileSystem then begin Result := FWin32FindDataA^.cAlternateFileName; if Result = '' then Result := WideUpperCase(FWin32FindDataA^.CFileName) end else Result := ''; end end; function TNamespace.GetSubFolders: Boolean; { Tests to see if a namespace is a true folder and has at least one } { sub-namespace within it. } begin Result := InternalSubItems(SHCONTF_FOLDERS or SHCONTF_INCLUDEHIDDEN) end; function TNamespace.GetSubItems: Boolean; { Tests to see if a namespace is a true folder and has at least one } { sub-namespace within it. } begin Result := InternalSubItems(SHCONTF_FOLDERS or SHCONTF_NONFOLDERS or SHCONTF_INCLUDEHIDDEN) end; function TNamespace.GetSystem: Boolean; { GETTER: Does the file attributes contain System? } begin if IsUnicode then begin if not Assigned(FWin32FindDataW) then GetDataFromIDList; if Assigned(FWin32FindDataW) and FileSystem then Result := FWin32FindDataW^.dwFileAttributes and FILE_ATTRIBUTE_SYSTEM <> 0 else Result := False; end else begin if not Assigned(FWin32FindDataA) then GetDataFromIDList; if Assigned(FWin32FindDataA) and FileSystem then Result := FWin32FindDataA^.dwFileAttributes and FILE_ATTRIBUTE_SYSTEM <> 0 else Result := False; end end; function TNamespace.GetTemporary: Boolean; { GETTER: Does the file attributes contain Temporary? } begin if IsUnicode then begin if not Assigned(FWin32FindDataW) then GetDataFromIDList; if Assigned(FWin32FindDataW) and FileSystem then Result := FWin32FindDataW^.dwFileAttributes and FILE_ATTRIBUTE_TEMPORARY <> 0 else Result := False; end else begin if not Assigned(FWin32FindDataA) then GetDataFromIDList; if Assigned(FWin32FindDataA) and FileSystem then Result := FWin32FindDataA^.dwFileAttributes and FILE_ATTRIBUTE_TEMPORARY <> 0 else Result := False; end end; function TNamespace.GetThreadedIconLoaded: Boolean; begin Result := nsThreadedIconLoaded in States end; function TNamespace.GetThreadIconLoading: Boolean; begin Result := nsThreadedIconLoading in States end; function TNamespace.GetShellIconOverlayInterface: IShellIconOverlay; var Found: Boolean; begin if (nsShellOverlaySupported in States) and not Assigned(FShellIconOverlayInterface) then begin Found := False; if Assigned(ShellFolder) then Found := ShellFolder.QueryInterface(IShellIconOverlay, Pointer(FShellIconOverlayInterface)) <> E_NOINTERFACE; if not Found then // Here we have to check again begin IF Assigned(ParentShellFolder) then Found := ParentShellFolder.QueryInterface(IShellIconOverlay, Pointer(FShellIconOverlayInterface)) <> E_NOINTERFACE; end; if not Found then begin Exclude(FStates, nsShellOverlaySupported); FShellIconOverlayInterface := nil end end; Result := FShellIconOverlayInterface end; procedure TNamespace.HandleContextMenuMsg(Msg, wParam, lParam: Longint; var Result: LRESULT); { This is called when the ContextMenu calls back to its owner window to ask } { questions to implement the addition of icons to the menu. The messages sent } { to the owner window are: WM_INITMENUPOPUP, WM_DRAWITEM, or WM_MEASUREITEM. } { Which must be passed on to the ContextMenu2 interface to display items with } { icons. } var ContextMenu3: IContextMenu3; begin if Assigned(CurrentContextMenu2) then if CurrentContextMenu2.QueryInterface(IContextMenu3, ContextMenu3) <> E_NOINTERFACE then ContextMenu3.HandleMenuMsg2(Msg, wParam, lParam, Result) else CurrentContextMenu2.HandleMenuMsg(Msg, wParam, lParam); end; function TNamespace.InjectCustomSubMenu(Menu: HMenu; Caption: string; PopupMenu: TPopupMenu; var SubMenu: HMenu): TMenuItemIDArray; const MENUMASK = MIIM_CHECKMARKS or MIIM_DATA or MIIM_ID or MIIM_STATE or MIIM_TYPE; { Searchs through the passed menu looking for an item identifer that is not } { currently being used. } function FindUniqueMenuID(AMenu: HMenu; StartID: cardinal): cardinal; var ItemCount, i: integer; Duplicate, Done: Boolean; begin ItemCount := GetMenuItemCount(Menu); Duplicate := True; Result := StartID; while Duplicate do begin i := 0; Done := False; while (i < ItemCount) and not Done do begin Done := GetMenuItemID(Menu, i) = Result; Inc(i); end; Duplicate := Done; if Duplicate then Inc(Result) end; end; var ItemCount, i: integer; ItemInfo: TMenuItemInfo; LastID: cardinal; begin Result := nil; SubMenu := 0; LastID := 0; ItemCount := GetMenuItemCount(Menu); SubMenu := CreatePopupMenu; FillChar(ItemInfo, SizeOf(ItemInfo), #0); ItemInfo.cbSize := SizeOf(ItemInfo); ItemInfo.fmask := MIIM_TYPE; ItemInfo.fType := MFT_SEPARATOR; InsertMenuItem(Menu, ItemCount, True, ItemInfo); FillChar(ItemInfo, SizeOf(ItemInfo), #0); ItemInfo.cbSize := SizeOf(ItemInfo); ItemInfo.fmask := MIIM_SUBMENU or MIIM_TYPE; ItemInfo.hSubMenu := SubMenu; ItemInfo.dwTypeData := PChar(Caption); // Insert the Root Menu Item if InsertMenuItem(Menu, ItemCount + 1, True, ItemInfo) then begin SetLength(Result, PopupMenu.Items.Count); for i := PopupMenu.Items.Count - 1 downto 0 do begin FillChar(ItemInfo, SizeOf(ItemInfo), #0); ItemInfo.cbSize := SizeOf(ItemInfo); ItemInfo.fmask := MENUMASK; if PopupMenu.Items[i].Caption <> '-' then ItemInfo.fType := MFT_STRING else ItemInfo.fType := MFT_SEPARATOR; if PopupMenu.Items[i].RadioItem then ItemInfo.fType := ItemInfo.fType or MFT_RADIOCHECK; if PopupMenu.BiDiMode = bdRightToLeft then ItemInfo.fType := ItemInfo.fType or MFT_RIGHTJUSTIFY; if PopupMenu.Items[i].Break = mbBreak then ItemInfo.fType := ItemInfo.fType or MFT_MENUBREAK; if PopupMenu.Items[i].Break = mbBarBreak then ItemInfo.fType := ItemInfo.fType or MFT_MENUBARBREAK; if PopupMenu.Items[i].Checked then ItemInfo.fState := ItemInfo.fState or MFS_CHECKED else ItemInfo.fState := ItemInfo.fState or MFS_UNCHECKED; if PopupMenu.Items[i].Default then ItemInfo.fState := ItemInfo.fState or MFS_DEFAULT; if PopupMenu.Items[i].Enabled then ItemInfo.fState := ItemInfo.fState or MFS_ENABLED else ItemInfo.fState := ItemInfo.fState or MFS_DISABLED; ItemInfo.wID := FindUniqueMenuID(Menu, LastID + 1); LastID := ItemInfo.wID; Result[i] := ItemInfo.wID; // Store the TMenuItem so we can get it later ItemInfo.dwItemData := Cardinal( PopupMenu.Items[i]); if not( ItemInfo.fType and MFT_SEPARATOR <> 0) then ItemInfo.dwTypeData := PChar(PopupMenu.Items[i].Caption); InsertMenuItem(SubMenu, 0, True, ItemInfo) end end end; function TNamespace.InternalGetContextMenuInterface(PIDLArray: TRelativePIDLArray): IContextMenu; var Found: Boolean; begin Found := False; CurrentContextMenu2 := nil; // Clear since not sure if it is avaiable yet if Assigned(PIDLArray) then begin if Assigned(ParentShellFolder) then begin Found := Succeeded(ParentShellFolder.GetUIObjectOf(ParentWnd, Length(PIDLArray), PItemIDList( PIDLArray[0]), IID_IContextMenu, nil, Pointer(Result))) end; if not Found and Assigned(ShellFolder) and (Length(PIDLArray) = 1) then begin Found := ShellFolder.CreateViewObject(ParentWnd, IID_IContextMenu, Pointer(Result)) = NOERROR; end; if not Found then Result := nil end else Result := nil end; function TNamespace.InternalGetDataObjectInterface(PIDLArray: TRelativePIDLArray): IDataObject; { Creates an IDataObject using the passed relative PIDLs (actually siblings of } { the TNamespace) If a nil is passed for PIDLArray a single object based on } { TNamespace is created. } var Found: Boolean; begin if not Assigned(PIDLArray) then begin SetLength(PIDLArray, 1); PIDLArray[0] := RelativePIDL end; Found := False; if Assigned(PIDLArray) then begin if Assigned(ParentShellFolder) then begin Found := ParentShellFolder.GetUIObjectOf(ParentWnd, Length(PIDLArray), PItemIDList( PIDLArray[0]), IDataObject, nil, Pointer(Result)) = NOERROR; end; if not Found and Assigned(ShellFolder) and (Length(PIDLArray) = 1) then begin Found := ShellFolder.CreateViewObject(ParentWnd, IDataObject, Pointer(Result)) = NOERROR; end; if not Found then Result := nil end else Result := nil end; function TNamespace.InternalShowContextMenu(Owner: TWinControl; ContextMenuCmdCallback: TContextMenuCmdCallback; ContextMenuShowCallback: TContextMenuShowCallback; ContextMenuAfterCmdCallback: TContextMenuAfterCmdCallback; PIDLArray: TRelativePIDLArray; Position: PPoint; CustomShellSubMenu: TPopupMenu; CustomSubMenuCaption: WideString): Boolean; // Displays the ContextMenu of the namespace. const MaxVerbLen = 128; var Menu: hMenu; InvokeInfo: TCMInvokeCommandInfoEx; MenuCmd: Cardinal; x, y, i: integer; OldErrorMode: integer; VerbA: string; VerbW: WideString; GenericVerb: Pointer; Handled, AllowShow: Boolean; Flags: Longword; ContextMenu: IContextMenu; ContextMenu2: IContextMenu2; ContextMenu3: IContextMenu3; MenuIDs: TMenuItemIDArray; ItemInfo: TMenuItemInfo; SubMenu: HMenu; OldMode: UINT; begin OldMode := SetErrorMode(SEM_FAILCRITICALERRORS); try MenuIDs := nil; Result := False; Assert(Assigned(Owner), 'To show a Context Menu using TNamespace you must pass a valid Owner TWinControl'); if Assigned(Owner) then begin FOldWndProcForContextMenu := Owner.WindowProc; try // Hook the owner for the Window message for owner draw menus like // Send To.. Owner.WindowProc := WindowProcForContextMenu; if Assigned(PIDLArray) then begin ContextMenu := nil; ContextMenu2 := nil; ContextMenu3 := nil; Result := False; if Assigned(Position) then begin x := Position.x; y := Position.y end else begin x := Mouse.CursorPos.X; // Snag these fast. The mouse can move a fair amount y := Mouse.CursorPos.Y; // before the popup menu is shown. end; FillChar(InvokeInfo, SizeOf(InvokeInfo), #0); Menu := CreatePopupMenu; OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOOPENFILEERRORBOX); try { The application must handle a rename, rename makes no sense for more than 1 item } if Assigned(ContextMenuCmdCallback) and (Length(PIDLArray) = 1) then Flags := CMF_CANRENAME or CMF_NORMAL or CMF_EXPLORE else Flags := CMF_NORMAL or CMF_EXPLORE; if GetKeyState(VK_SHIFT) and $8000 <> 0 then Flags := Flags or CMF_EXTENDEDVERBS; if Assigned(PIDLArray) then ContextMenu := InternalGetContextMenuInterface(PIDLArray) else ContextMenu := ContextMenuInterface; CurrentContextMenu := ContextMenu; CurrentContextMenu2 := nil; // not sure it is available yet if Assigned(ContextMenu) then begin if ContextMenu.QueryInterface(IContextMenu3, Pointer(ContextMenu3)) = E_NOINTERFACE then begin if ContextMenu.QueryInterface(IID_IContextMenu2, Pointer(ContextMenu2)) <> E_NOINTERFACE then CurrentContextMenu2 := ContextMenu2; end else CurrentContextMenu2 := ContextMenu3; if Assigned(ContextMenu3) then ContextMenu3.QueryContextMenu(Menu, 0, 1, $7FFF, Flags) else if Assigned(ContextMenu2) then ContextMenu2.QueryContextMenu(Menu, 0, 1, $7FFF, Flags) else if Assigned(ContextMenu) then ContextMenu.QueryContextMenu(Menu, 0, 1, $7FFF, Flags); // Inject our custom menu item if Assigned(CustomShellSubMenu) then MenuIDs := InjectCustomSubMenu(Menu, CustomSubMenuCaption, CustomShellSubMenu, SubMenu); AllowShow := True; if Assigned(ContextMenuShowCallback) then ContextMenuShowCallback(Self, Menu, AllowShow); if AllowShow then MenuCmd := Cardinal( TrackPopupMenuEx( Menu, TPM_LEFTALIGN or TPM_RETURNCMD or TPM_RIGHTBUTTON, x, y, Owner.Handle, nil)) else MenuCmd := 0; if MenuCmd <> 0 then begin if IsUnicode then begin SetLength(VerbW, MaxVerbLen); GenericVerb := @VerbW[1]; Flags := GCS_VERBW end else begin SetLength(VerbA, MaxVerbLen); GenericVerb := @VerbA[1]; Flags := GCS_VERBA end; if Assigned(ContextMenu3) then Result := Succeeded(ContextMenu3.GetCommandString(MenuCmd-1, Flags, nil, GenericVerb, MaxVerbLen)) else if Assigned(ContextMenu2) then Result := Succeeded(ContextMenu2.GetCommandString(MenuCmd-1, Flags, nil, GenericVerb, MaxVerbLen)) else if Assigned(ContextMenu) then Result := Succeeded(ContextMenu.GetCommandString(MenuCmd-1, Flags, nil, GenericVerb, MaxVerbLen)); if IsUnicode then SetLength(VerbW, lstrlenW(PWideChar( VerbW))) else begin SetLength(VerbA, StrLen(PChar( VerbA))); VerbW := VerbA end; if not Result then VerbW := STR_UNKNOWNCOMMAN; Handled := False; for i := 0 to Length(MenuIDs) - 1 do begin if MenuCmd = MenuIDs[i] then begin if SubMenu <> 0 then begin Handled := True; FillChar(ItemInfo, SizeOf(ItemInfo), #0); ItemInfo.cbSize := SizeOf(TMenuItemInfo); ItemInfo.fMask := MIIM_DATA; GetMenuItemInfo(SubMenu, i, True, ItemInfo); if ItemInfo.dwItemData <> 0 then TMenuItem(ItemInfo.dwItemData).Click end end end; if not Handled then if Assigned(ContextMenuCmdCallback) then ContextMenuCmdCallBack(Self, VerbW, MenuCmd, Handled); if not Handled then begin FillChar(InvokeInfo, SizeOf(InvokeInfo), #0); with InvokeInfo do begin { For some reason the lpVerbW won't work } lpVerb := MakeIntResourceA(MenuCmd-1); if IsUnicode then begin fMask := CMIC_MASK_UNICODE; lpVerbW := MakeIntResourceW(MenuCmd-1) end; // Win95 get confused if size = TCMInvokeCommandInfoEx if IsUnicode then cbSize := SizeOf(TCMInvokeCommandInfoEx) else cbSize := SizeOf(TCMInvokeCommandInfo); hWnd := Owner.Handle; nShow := SW_SHOWNORMAL; end; if Assigned(ContextMenu3) then Result := Succeeded(ContextMenu3.InvokeCommand(InvokeInfo)) else if Assigned(ContextMenu2) then Result := Succeeded(ContextMenu2.InvokeCommand(InvokeInfo)) else if Assigned(ContextMenu) then Result := Succeeded(ContextMenu.InvokeCommand(InvokeInfo)); end end; if Assigned(ContextMenuAfterCmdCallback) then ContextMenuAfterCmdCallback(Self, VerbW, MenuCmd, Result); end; finally { Don't access any properties or field of the object. If the verb is } { 'delete' the component using this class could have freed the instance } { of the object through a ShellNotifyRegister or some other way. } DestroyMenu(Menu); SetErrorMode(OldErrorMode); end end finally Owner.WindowProc := FOldWndProcForContextMenu; FOldWndProcForContextMenu := nil; // Don't nil until after the hook is unset CurrentContextMenu := nil; CurrentContextMenu2 := nil; // not sure it is available yet end end finally SetErrorMode(OldMode) end end; function TNamespace.OkToBrowse(ShowExplorerMsg: Boolean): Boolean; var S: WideString; begin Result := True; S := NameForParsing; if ((Length(S) = 3) and (S[2] = ':') and (S[3] = '\')) then Result := DiskInDrive(Char(S[1])); if not Result and ShowExplorerMsg then EnumerateFolderEx(ParentWnd, [foFolders, foNonFolders, foHidden], nil, nil) end; function TNamespace.InternalSubItems(Flags: Longword): Boolean; { Tests to see if a namespace is a true folder and has at least one } { sub-namespace within it. } var Enum: IEnumIDList; Fetched: Longword; Item: PItemIDList; OldError: DWORD; begin Result := False; OldError := SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOOPENFILEERRORBOX); try { The recycle bin enumerates slow if it is full. VT will InitNode for various } { reasons eventhough the node is not expanded. We will always assume there is } { is something in the bin. If not when it is clicked it will clear the "+" } if IsRecycleBin then Result := True else // if ILIsParent(HistoryFolder.AbsolutePIDL, AbsolutePIDL, False) then // Result := True // else begin if Folder and Assigned(ShellFolder) then begin Item := nil; Enum := nil; // Since this is just an internal test don't show any dialogs so send a 0 if ShellFolder.EnumObjects(0, Flags, Enum) = NOERROR then begin // Vista Enum is nil every once in a while if Assigned(Enum) then begin Result := Enum.Next(1, Item, Fetched) = NOERROR; if Assigned(Item) then PIDLMgr.FreePIDL(Item) end end end end finally SetErrorMode(OldError); end end; procedure TNamespace.InvalidateCache; { Forces the class to reload any cached data the next time it is retrieved. } begin FShellCache.Data.InFolderName := ''; FShellCache.Data.NormalName := ''; FShellCache.Data.ParsedName := ''; FShellCache.Data.SmallIcon := -1; FShellCache.Data.SmallOpenIcon := -1; FShellCache.Data.OverlayIndex := -1; FShellCache.Data.OverlayIconIndex := -1; FShellCache.Data.CreationTime := ''; FShellCache.Data.LastAccessTime := ''; FShellCache.Data.LastWriteTime := ''; FShellCache.Data.FileSize := ''; FShellCache.Data.FileSizeKB := ''; FShellCache.Data.FileType := ''; FShellCache.Data.FileSizeInt64 := 0; FShellCache.Data.SupportedColumns := 0; FShellCache.Data.Attributes := []; SetLength(FShellCache.Data.DetailsOfCache, 0); FShellCache.ShellCacheFlags := []; FreeAndNil(FExtractImage); FreeAndNil(FShellLink); InvalidateThumbImage end; procedure TNamespace.InvalidateNamespace(RefreshIcon: Boolean = True); var Icon1, Icon2: integer; Icon1Initialized, Icon2Initialized: Boolean; begin Icon1 := 0; Icon2 := 0; Icon1Initialized := False; Icon2Initialized := False; if not RefreshIcon then begin if scSmallIcon in FShellCache.ShellCacheFlags then begin Icon1Initialized := True; Icon1 := FShellCache.Data.SmallIcon; end; if scSmallOpenIcon in FShellCache.ShellCacheFlags then begin Icon2Initialized := True; Icon2 := FShellCache.Data.SmallOpenIcon; end; end else begin // Flush the thread state so the icon is reloaded by the thread States := States - [nsThreadedIconLoading]; States := States - [nsThreadedIconLoaded]; end; InvalidateDetailsOfCache(True); InvalidateCache; if nsOwnsParent in States then FreeAndNil(FParent); FDropTargetInterface := nil; FShellDetailsInterface := nil; FShellIconOverlayInterface := nil; FShellFolder := nil; if Assigned(Parent) then if Parent.IsDesktop then PhysicalDesktopFolder.InvalidateNamespace; if IsUnicode then begin if Assigned(FWin32FindDataW) then FreeMem(FWin32FindDataW, SizeOf(TWin32FindDataW)); FWin32FindDataW := nil; end else begin if Assigned(FWin32FindDataA) then FreeMem(FWin32FindDataA, SizeOf(TWin32FindDataA)); FWin32FindDataA := nil; end; if Assigned(FSHGetFileInfoRec) then begin Finalize(FSHGetFileInfoRec^); FreeMem(FSHGetFileInfoRec, SizeOf(TSHGetFileInfoRec)); end; FSHGetFileInfoRec := nil; Include(FStates, nsShellDetailsSupported); // Be optomistic Include(FStates, nsShellFolder2Supported); // Be optomistic FQueryInfoInterface := nil; FShellIconInterface := nil; FCurrentContextMenu2 := nil; if not RefreshIcon then begin if Icon1Initialized then begin Include(FShellCache.ShellCacheFlags, scSmallIcon); FShellCache.Data.SmallIcon := Icon1; end; if Icon2Initialized then begin Include(FShellCache.ShellCacheFlags, scSmallOpenIcon); FShellCache.Data.SmallOpenIcon := Icon2; end; end; end; procedure TNamespace.InvalidateRelativePIDL(FileObjects: TFileObjects); var Enum: IEnumIDList; Flags: Longword; Fetched: Longword; Item: PItemIDList; Done: Boolean; begin if Assigned(ParentShellFolder) then begin Flags := FileObjectsToFlags(FileObjects); Done := False; if ParentShellFolder.EnumObjects(ParentWnd, Flags, Enum) = NOERROR then begin // Vista Enum is nil every once in a while if Assigned(Enum) then begin while (Enum.Next(1, Item, Fetched) = NOERROR) and not Done do begin if ComparePIDL(Item, False) = 0 then begin PIDLMgr.FreePIDL(FAbsolutePIDL); FAbsolutePIDL := PIDLMgr.AppendPIDL(Parent.AbsolutePIDL, Item); FRelativePIDL := PIDLMgr.GetPointerToLastID(FAbsolutePIDL); InvalidateNamespace; Done := True end; PIDLMgr.FreePIDL(Item) end end end end end; function TNamespace.IsChildByNamespace(TestNamespace: TNamespace; Immediate: Boolean): Boolean; { Returns True if the TestNamespace is a child of the namespace. Immediate } { forces function to be true only of the passed PIDL is the immidiate child } { of the namespace. } begin Result := Boolean( ILIsParent(FAbsolutePIDL, TestNamespace.FAbsolutePIDL, Immediate)); end; function TNamespace.IsChildByPIDL(TestPIDL: PItemIDList; Immediate: Boolean): Boolean; { Returns True if the TestPIDL is a child of the namespace. Immediate forces } { function to be true only of the passed PIDL is the immidiate child of the } { namespace. } begin Result := Boolean( ILIsParent(FAbsolutePIDL, TestPIDL, Immediate)); end; function TNamespace.IsChildOfRemovableDrive: Boolean; // Checks to see if the namespace is a child of a removable drive. If the drive // is removed then ILIsParent fails because the drive is no longer valid so any // PIDL walking routines will fail and the PIDL is orphaned var NS: TNamespace; PIDL, NewPIDL: PItemIDList; OldCB: Word; begin Result := False; if PIDLMgr.IDCount(AbsolutePIDL) > 1 then begin PIDL := PIDLMgr.NextID(FAbsolutePIDL); PIDL := PIDLMgr.NextID(PIDL); // Now we have the Drive PIDL := PIDLMgr.NextID(PIDL); // Now we have the one past the Drive OldCb := PIDL.mkid.cb; PIDL.mkid.cb := 0; NewPIDL := PIDLMgr.CopyPIDL(FAbsolutePIDL); PIDL.mkid.cb := OldCB; // NS is now a TNamespace to the Drive NS := TNamespace.Create(NewPIDL, nil); Result := NS.Removable; NS.Free end end; function TNamespace.IsControlPanel: Boolean; begin if Assigned(ControlPanelFolder) then Result := ILIsEqual(AbsolutePIDL, ControlPanelFolder.AbsolutePIDL) else Result := False end; function TNamespace.IsControlPanelChildFolder: Boolean; begin if Assigned(ControlPanelFolder) then Result := ILIsParent(ControlPanelFolder.AbsolutePIDL, AbsolutePIDL, True) else Result := False end; function TNamespace.IsDesktop: Boolean; begin Result := PIDLMgr.IsDesktopFolder(AbsolutePIDL) end; function TNamespace.IsMyComputer: Boolean; begin if Assigned(DrivesFolder) then Result := ILIsEqual(DrivesFolder.AbsolutePIDL, AbsolutePIDL) else Result := False; end; function TNamespace.IsNetworkNeighborhood: Boolean; begin if Assigned(NetworkNeighborHoodFolder) then Result := ILIsEqual(NetworkNeighborHoodFolder.AbsolutePIDL, AbsolutePIDL) else Result := False; end; function TNamespace.IsNetworkNeighborhoodChild: Boolean; begin if Assigned(NetworkNeighborHoodFolder) then Result := ILIsParent(NetworkNeighborHoodFolder.AbsolutePIDL, AbsolutePIDL, False) else Result := False; end; function TNamespace.IsParentByNamespace(TestNamespace: TNamespace; Immediate: Boolean): Boolean; { Returns True if the TestNamespace is a parent of the namespace. Immediate } { forces function to be true only of the passed PIDL is the immidiate parent } { of the namespace. } begin Result := Boolean( ILIsParent(TestNamespace.FAbsolutePIDL, FAbsolutePIDL, Immediate)); end; function TNamespace.IsParentByPIDL(TestPIDL: PItemIDList; Immediate: Boolean): Boolean; { Returns True if the TestPIDL is a parent of the namespace. Immediate forces } { function to be true only of the passed PIDL is the immidiate parent of the } { namespace. } begin Result := Boolean( ILIsParent(TestPIDL, FAbsolutePIDL, Immediate)); end; function TNamespace.IsRecycleBin: Boolean; begin { RecycleBin may not be avaiable if System Administrator has removed it in Win2k at least } if Assigned(RecycleBinFolder) and not (nsRecycleBinChecked in States) then begin if ILIsEqual(AbsolutePIDL, RecycleBinFolder.AbsolutePIDL) then Include(FStates, nsIsRecycleBin) else Exclude(FStates, nsIsRecycleBin); Include(FStates, nsRecycleBinChecked); end; Result := nsIsRecycleBin in States; end; function TNamespace.ParseDisplayName: PItemIDList; begin Result := ParseDisplayName(NameForParsing) end; function TNamespace.ParseDisplayName(Path: WideString): PItemIDList; var chEaten: ULONG; Attrib: ULONG; Desktop: IShellFolder; begin Result := nil; Attrib := 0; SHGetDesktopFolder(Desktop); if Assigned(Desktop) then begin if Desktop.ParseDisplayName(ParentWnd, nil, PWideChar( Path), chEaten, Result, Attrib) <> NOERROR then Result := nil; end end; function TNamespace.Paste(NamespaceArray: TNamespaceArray; AsShortCut: Boolean = False): Boolean; var NSA: TNamespaceArray; i: integer; begin Result := False; if CanPasteToAll(NamespaceArray) then begin if IsDesktop then begin SetLength(NSA, Length(NamespaceArray)); // Convert the virtual Desktop based TNamespaces to the Physical Desktop Folder based TNamespaces for i := 0 to Length(NSA) - 1 do NSA[i] := TNamespace.Create(PathToPIDL(NamespaceArray[i].NameForParsing), nil); Result := PhysicalDesktopFolder.Paste(NSA, AsShortCut); end else begin if VerifyPIDLRelationship(NamespaceArray, True) then begin if AsShortCut then Result := ExecuteContextMenuVerb('pastelink', NamespaceToRelativePIDLArray(NamespaceArray)) else Result := ExecuteContextMenuVerb('paste', NamespaceToRelativePIDLArray(NamespaceArray)) end else begin if AsShortCut then ExecuteContextMenuVerbMultiPath('pastelink', NamespaceArray) else ExecuteContextMenuVerbMultiPath('paste', NamespaceArray) end end end end; procedure TNamespace.LoadCategoryInfo; var ColumnID: TSHColumnID; CatGUID: TGUID; Buffer: WideString; i: Integer; Done: Boolean; begin if (CatInfo.CategoryCount = 0) and Assigned(ShellFolder2) and Assigned(CategoryProviderInterface) then begin CatGUID := GUID_NULL; FCatInfo.CategoryCount := DetailsSupportedColumns; SetLength(FCatInfo.Categories, DetailsSupportedColumns); SetLength(FCatInfo.CategoryNames, DetailsSupportedColumns); SetLength(FCatInfo.CatGUID, DetailsSupportedColumns); SetLength(FCatInfo.ColumnID, DetailsSupportedColumns); SetLength(FCatInfo.CanCatatorize, DetailsSupportedColumns); SetLength(Buffer, 256); for i := 0 to DetailsSupportedColumns - 1 do begin FillChar(ColumnID, SizeOf(ColumnID), #0); FillChar(PWideChar( Buffer)^, 256 * 2, #0); CatGUID := GUID_NULL; FCatInfo.Categories[i].Description := ''; FCatInfo.Categories[i].Collapsed := False; FCatInfo.Categories[i].Hidden := False; FCatInfo.CategoryNames[i] := ''; FCatInfo.ColumnID[i].pid := 0; FCatInfo.ColumnID[i].fmtid := GUID_NULL; FCatInfo.CatGUID[i] := GUID_NULL; FCatInfo.CanCatatorize[i] := False; FCatInfo.DefaultColumn := -1; if Succeeded(ShellFolder2.MapColumnToSCID(i, ColumnID)) then begin CatInfo.ColumnID[i] := ColumnID; if Succeeded(CategoryProviderInterface.CanCategorizeOnSCID(ColumnID)) then begin ColumnID := CatInfo.ColumnID[i]; CatInfo.CanCatatorize[i] := True; if Succeeded(CategoryProviderInterface.GetCategoryForSCID(ColumnID, CatGUID)) then begin ColumnID := CatInfo.ColumnID[i]; CatInfo.CatGUID[i] := CatGUID; if not IsEqualGUID(CatGUID, GUID_NULL) then if Succeeded(CategoryProviderInterface.GetCategoryName(CatGUID, PWideChar(Buffer), 256)) then begin FCatInfo.CategoryNames[i] := Buffer; SetLength(FCatInfo.CategoryNames[i], lstrlenW(PWideChar(FCatInfo.CategoryNames[i]))); end end end end end; CatGUID := GUID_NULL; if Succeeded(CategoryProviderInterface.GetDefaultCategory(CatGUID, ColumnID)) then begin i := 0; Done := False; while (i < Length(CatInfo.ColumnID)) and not Done do begin if IsEqualGUID(ColumnID.fmtid, CatInfo.ColumnID[i].fmtid) and (ColumnID.pid = CatInfo.ColumnID[i].pid) then begin FCatInfo.DefaultColumn := i; Done := True end; Inc(i) end end end end; procedure TNamespace.SetDetailByThread(ColumnIndex: Integer; Detail: WideString); var TempCache: PDetailsOfCacheRec; begin EnsureDetailCache; if DetailsValidIndex(ColumnIndex) then begin TempCache := @ShellCache.Data.DetailsOfCache[ColumnIndex]; TempCache.Caption := Detail; Include(TempCache.Cached, docCaptionValid); Include(TempCache.Cached, docThreadLoaded); Exclude(TempCache.Cached, docThreadLoading); end end; procedure TNamespace.SetFreePIDLOnDestroy(const Value: Boolean); begin if Value then Include(FStates, nsFreePIDLOnDestroy) else Exclude(FStates, nsFreePIDLOnDestroy) end; procedure TNamespace.SetIconIndexChanged(const Value: Boolean); // Sets or resets if the index changed. Currently the SetIconIndexByThread method sets // this flag. It is not reset automaticlly it is up to the application to reset then // when it has detected and used it. begin if Value then Include(FStates, nsIconIndexChanged) else Exclude(FStates, nsIconIndexChanged); end; procedure TNamespace.SetIconIndexByThread(IconIndex: Integer; ClearThreadLoading: Boolean); begin Include(FStates, nsThreadedIconLoaded); // Small Normal Icon is now Cached FShellCache.Data.SmallIcon := IconIndex; Include(FShellCache.ShellCacheFlags, scSmallIcon); if ClearThreadLoading then Exclude(FStates, nsThreadedIconLoading); IconIndexChanged := True; end; procedure TNamespace.SetImageByThread(Bitmap: TBitmap; ClearThreadLoading: Boolean); begin Include(FStates, nsThreadedImageLoaded); FImage := Bitmap; if ClearThreadLoading then Exclude(FStates, nsThreadedImageLoading); end; function TNamespace.SetNameOf(NewName: WideString): Boolean; const ALL_FOLDERS = SHCONTF_FOLDERS or SHCONTF_NONFOLDERS or SHCONTF_INCLUDEHIDDEN; var P, NewPIDL, NewAbsPIDL: PItemIDList; Oldcb: Word; OldCursor: TCursor; begin Result := False; if CanRename and Assigned(ParentShellFolder) then begin OldCursor := Screen.Cursor; Screen.Cursor := crHourglass; try { The shell frees the PIDL so we need a copy } P := PIDLMgr.CopyPIDL(FRelativePIDL); NewPIDL := nil; if Succeeded(ParentShellFolder.SetNameOf(ParentWnd, P, PWideChar(NewName), ALL_FOLDERS, NewPIDL)) then begin // Win98 will return success but never touch NewPIDL when trying to change name // of dialup connection. Not sure how do it if this fails though?? if Assigned(NewPIDL) then begin Result := True; { Temporary shortening of AbsolutePIDL } Oldcb := RelativePIDL.mkid.cb; RelativePIDL.mkid.cb := 0; NewAbsPIDL := PIDLMgr.AppendPIDL(AbsolutePIDL, NewPIDL); RelativePIDL.mkid.cb := Oldcb; PIDLMgr.FreePIDL(FAbsolutePIDL); // Remember Relative PIDL overlays AbsPIDL FAbsolutePIDL := NewAbsPIDL; FRelativePIDL := PIDLMgr.GetPointerToLastID(AbsolutePIDL); end end finally Screen.Cursor := OldCursor end end; end; procedure TNamespace.SetThreadedDetailLoaded(ColumnIndex: Integer; Value: Boolean); begin EnsureDetailCache; if DetailsValidIndex(ColumnIndex) then Include(ShellCache.Data.DetailsOfCache[ColumnIndex].Cached, docThreadLoaded) end; procedure TNamespace.SetThreadedDetailLoading(ColumnIndex: Integer; Value: Boolean); begin EnsureDetailCache; if DetailsValidIndex(ColumnIndex) then Include(ShellCache.Data.DetailsOfCache[ColumnIndex].Cached, docThreadLoading) end; procedure TNamespace.SetThreadIconLoading(const Value: Boolean); begin if Value then Include(FStates, nsThreadedIconLoading) else Exclude(FStates, nsThreadedIconLoading) end; function TNamespace.GetThreadedImageLoaded: Boolean; begin Result := nsThreadedImageLoaded in States end; function TNamespace.GetThreadedImageLoading: Boolean; begin Result := nsThreadedImageLoading in States end; procedure TNamespace.SetThreadImageLoading(const Value: Boolean); begin if Value then Include(FStates, nsThreadedImageLoading) else Exclude(FStates, nsThreadedImageLoading) end; function TNamespace.ShellExecuteNamespace(WorkingDir, CmdLineArguments: WideString; ExecuteFolder: Boolean = False; ExecuteFolderShortCut: Boolean = False; RunInThread: Boolean = False): Boolean; { Attempts execute the object that the namespace is representing. WorkingDir } { is the directory that will be the current directory of the application that } { is being executed. If the directory does not exist the directory where the } { file being executed resides. CmdLineArguments are any switches or parameters } { that can be added to the file being executed. } { ExecuteFolder stops the call from being performed if the namespace is a folder} { Doing so usually opens an explorer window to Explore the folder. } var ShellExecuteInfoA: TShellExecuteInfoA; ShellExecuteInfoW: TShellExecuteInfoW; ShortWorkingDir, ShortCmdLine: string; DoExecute: Boolean; ShellLink: TVirtualShellLink; ShellExecuteThread: TCommonShellExecuteThread; begin Result := False; DoExecute := True; if not ExecuteFolder then DoExecute := not Folder; if not ExecuteFolderShortCut and DoExecute then begin if Link then begin ShellLink := TVirtualShellLink.Create(nil); try ShellLink.ReadLink(NameParseAddress); DoExecute := not WideDirectoryExists(ShellLink.TargetPath); finally ShellLink.Free end end end; if DoExecute then begin if Win32Platform = VER_PLATFORM_WIN32_NT then begin FillChar(ShellExecuteInfoW, SizeOf(TShellExecuteInfoW), #0); if WideDirectoryExists(WorkingDir) then ShellExecuteInfoW.lpDirectory := PWideChar(WorkingDir) else // This should always be a file not a folder so this is ok ShellExecuteInfoW.lpDirectory := PWideChar(WideExtractFileDir(NameParseAddress)); ShellExecuteInfoW.cbSize := SizeOf(TShellExecuteInfoW); ShellExecuteInfoW.fMask := SEE_MASK_INVOKEIDLIST or SEE_MASK_NOCLOSEPROCESS; if RunInThread then ShellExecuteInfoW.fMask := ShellExecuteInfoW.fMask or SEE_MASK_FLAG_DDEWAIT; ShellExecuteInfoW.Wnd:= ParentWnd; ShellExecuteInfoW.nShow := SW_SHOWNORMAL; ShellExecuteInfoW.lpIDList:= AbsolutePIDL; ShellExecuteInfoW.lpParameters := PWideChar(CmdLineArguments); if RunInThread then begin ShellExecuteThread := TCommonShellExecuteThread.Create(True); ShellExecuteThread.ShellExecuteInfoW.cbSize := ShellExecuteInfoW.cbSize; ShellExecuteThread.ShellExecuteInfoW.fMask := ShellExecuteInfoW.fMask; ShellExecuteThread.ShellExecuteInfoW.Wnd := ShellExecuteInfoW.Wnd; ShellExecuteThread.ShellExecuteInfoW.nShow := ShellExecuteInfoW.nShow; ShellExecuteThread.ShellExecuteInfoW.hInstApp := ShellExecuteInfoW.hInstApp; ShellExecuteThread.ShellExecuteInfoW.hkeyClass := ShellExecuteInfoW.hkeyClass; ShellExecuteThread.ShellExecuteInfoW.dwHotKey := ShellExecuteInfoW.dwHotKey; ShellExecuteThread.ShellExecuteInfoW.hIcon := ShellExecuteInfoW.hIcon; ShellExecuteThread.ShellExecuteInfoW.hProcess := ShellExecuteInfoW.hProcess; ShellExecuteThread.lpDirectory := ShellExecuteInfoW.lpDirectory; ShellExecuteThread.lpParameters := ShellExecuteInfoW.lpParameters; ShellExecuteThread.PIDL := PIDLMgr.CopyPIDL(ShellExecuteInfoW.lpIDList); ShellExecuteThread.Resume; Result := True; end else Result := ShellExecuteExW_MP(@ShellExecuteInfoW); end else begin FillChar(ShellExecuteInfoA, SizeOf(TShellExecuteInfo), #0); if WideDirectoryExists(WorkingDir) then ShortWorkingDir := WorkingDir else ShortWorkingDir := ExtractFileDir(NameParseAddress); ShellExecuteInfoA.lpDirectory := PChar(ShortWorkingDir); ShellExecuteInfoA.cbSize := SizeOf(TShellExecuteInfo); ShellExecuteInfoA.fMask := SEE_MASK_INVOKEIDLIST or SEE_MASK_NOCLOSEPROCESS; if RunInThread then ShellExecuteInfoA.fMask := ShellExecuteInfoA.fMask or SEE_MASK_FLAG_DDEWAIT; ShellExecuteInfoA.Wnd:= ParentWnd; ShellExecuteInfoA.nShow := SW_SHOWNORMAL; ShellExecuteInfoA.lpIDList:= AbsolutePIDL; ShortCmdLine := CmdLineArguments; ShellExecuteInfoA.lpParameters := PChar(ShortCmdLine); if RunInThread then begin ShellExecuteThread := TCommonShellExecuteThread.Create(True); ShellExecuteThread.ShellExecuteInfoA.cbSize := ShellExecuteInfoA.cbSize; ShellExecuteThread.ShellExecuteInfoA.fMask := ShellExecuteInfoA.fMask; ShellExecuteThread.ShellExecuteInfoA.Wnd := ShellExecuteInfoA.Wnd; ShellExecuteThread.ShellExecuteInfoA.nShow := ShellExecuteInfoA.nShow; ShellExecuteThread.ShellExecuteInfoA.hInstApp := ShellExecuteInfoA.hInstApp; ShellExecuteThread.ShellExecuteInfoA.hkeyClass := ShellExecuteInfoA.hkeyClass; ShellExecuteThread.ShellExecuteInfoA.dwHotKey := ShellExecuteInfoA.dwHotKey; ShellExecuteThread.ShellExecuteInfoA.hIcon := ShellExecuteInfoA.hIcon; ShellExecuteThread.ShellExecuteInfoA.hProcess := ShellExecuteInfoA.hProcess; ShellExecuteThread.lpDirectory := ShellExecuteInfoA.lpDirectory; ShellExecuteThread.lpParameters := ShellExecuteInfoA.lpParameters; ShellExecuteThread.PIDL := PIDLMgr.CopyPIDL(ShellExecuteInfoA.lpIDList); ShellExecuteThread.Resume; Result := True; end else Result := ShellExecuteEx(@ShellExecuteInfoA); end end end; function TNamespace.ShowContextMenu(Owner: TWinControl; ContextMenuCmdCallback: TContextMenuCmdCallback; ContextMenuShowCallback: TContextMenuShowCallback; ContextMenuAfterCmdCallback: TContextMenuAfterCmdCallback; Position: PPoint = nil; CustomShellSubMenu: TPopupMenu = nil; CustomSubMenuCaption: WideString = ''): Boolean; { Displays the ContextMenu of the namespace. } var PIDLArray: TRelativePIDLArray; begin SetLength(PIDLArray, 1); PIDLArray[0] := RelativePIDL; Result := InternalShowContextMenu(Owner, ContextMenuCmdCallback, ContextMenuShowCallback, ContextMenuAfterCmdCallback, PIDLArray, Position, CustomShellSubMenu, CustomSubMenuCaption); end; function TNamespace.ShowContextMenuMulti(Owner: TWinControl; ContextMenuCmdCallback: TContextMenuCmdCallback; ContextMenuShowCallback: TContextMenuShowCallback; ContextMenuAfterCmdCallback: TContextMenuAfterCmdCallback; NamespaceArray: TNamespaceArray; Position: PPoint = nil; CustomShellSubMenu: TPopupMenu = nil; CustomSubMenuCaption: WideString = ''): Boolean; begin Result := False; if VerifyPIDLRelationship(NamespaceArray, True) then begin Result := InternalShowContextMenu(Owner, ContextMenuCmdCallBack, ContextMenuShowCallback, ContextMenuAfterCmdCallback, NamespaceToRelativePIDLArray(NamespaceArray), Position, CustomShellSubMenu, CustomSubMenuCaption) end else begin if Length(NamespaceArray) > 0 then ShowContextMenuMultiPath(Owner, NamespaceArray[0], NamespaceArray, Position) end end; function TNamespace.ShowContextMenuMultiPath(Owner: TWinControl; Focused: TNamespace; Namespaces: TNamespaceArray; Position: PPoint = nil): Boolean; var Menu: TCommonShellMultiParentContextMenu; Temp: TWinControl; begin Menu := TCommonShellMultiParentContextMenu.Create(nil); Temp := TWinControl.CreateParented(GetDesktopWindow); try Temp.Width := 0; Temp.Height := 0; Temp.Visible := True; Result := Menu.ShowContextMenu(Owner, Focused, Namespaces, Position); Temp.Visible := False; finally Temp.Free; Menu.Free end end; procedure TNamespace.ShowPropertySheet; var NamespaceArray: TNamespaceArray; begin if HasPropSheet then begin SetLength(NamespaceArray, 1); NamespaceArray[0] := Self; if VerifyPIDLRelationship(NamespaceArray, True) then ExecuteContextMenuVerb('properties', NamespaceToRelativePIDLArray(NamespaceArray)) else ExecuteContextMenuVerbMultiPath('properties', NamespaceArray) end end; procedure TNamespace.ShowPropertySheetMulti(NamespaceArray: TNamespaceArray; UseSHMultiFileProperties: Boolean = True; ForceNonMultiPath: Boolean = False); var IDO: IDataObject; begin if CanShowPropertiesOfAll(NamespaceArray) then begin // Call SHMultiFileProperties_MP to show the property sheet when the // APIDLArray items are from different folders. // Minimum OS: Win2k if not ForceNonMultiPath and (UseSHMultiFileProperties and Assigned(SHMultiFileProperties_MP)) then begin CreateFullyQualifiedShellDataObject(NamespaceToAbsolutePIDLArray(NamespaceArray), IDO); if Assigned(IDO) then SHMultiFileProperties_MP(IDO, 0); IDO._Release // I did this in DefMenuCreateCallback, I don't know why I have to but I do end else begin if VerifyPIDLRelationship(NamespaceArray, True) or ForceNonMultiPath then ExecuteContextMenuVerb('properties', NamespaceToRelativePIDLArray(NamespaceArray)) else ExecuteContextMenuVerbMultiPath('properties', NamespaceArray) end end end; function TNamespace.TestAttributesOf(Flags: Longword; FlushCache: Boolean; SoftFlush: Boolean = False): Boolean; // Pass any of the flags for IShellFolder.GetAttributesOf to see if they exist // for the Folder. FlushCache forces the shell to reload the information on the // namespace. Useful to handle the bug where the shell caches the icon for a // CD drive and never changes it. Flushing it will force it to reload the Index // Note this is dangerous with 3rd party namespaces. M$ suggests this method for // their namespaces but at least Hummingbird network namespace crashes with this // they apparently don't check for 0 PIDL's // Soft Flush add the SFGAO_VALIDATE flag to get the fresh info var x: Longword; begin if Assigned(ParentShellFolder) then begin x := Flags; if FlushCache then begin x := x or SFGAO_VALIDATE; ParentShellFolder.GetAttributesOf(0, FRelativePIDL, x); end else if SoftFlush then begin x := x or SFGAO_VALIDATE; ParentShellFolder.GetAttributesOf(1, FRelativePIDL, x) end else ParentShellFolder.GetAttributesOf(1, FRelativePIDL, x); Result := Flags and x = Flags; end else Result := False; end; function TNamespace.VerifyPIDLRelationship(NamespaceArray: TNamespaceArray; Silent: Boolean = False): Boolean; var i: integer; begin Result := True; i := 0; while (i < Length(NamespaceArray)) and Result do begin { TNamespace is based off using the parent to access the data so it is } { correct to do the test for childPIDLs relative from the parent. } if IsDesktop and (Length(NamespaceArray) = 1) then begin Result := (PIDLMgr.IDCount(NamespaceArray[i].AbsolutePIDL) = 1) or (NamespaceArray[0].IsDesktop) end else begin if Assigned(Parent) then Result := ILIsParent(Parent.AbsolutePIDL, NamespaceArray[i].AbsolutePIDL, True) else begin if (Length(NamespaceArray) = 1) and NamespaceArray[0].IsDesktop then Result := True else Result := False; end end; Inc(i) end; if not Silent and (not Result and not IsDesktop) then WideShowMessage(ParentWnd, STR_ERROR, STR_ERR_BAD_PIDL_RELATIONSHIP); end; procedure TNamespace.WindowProcForContextMenu(var Message: TMessage); begin if Assigned(FOldWndProcForContextMenu) then FOldWndProcForContextMenu(Message); // Call the OldWindProc of the ContextMenu owner case Message.Msg of WM_DRAWITEM, WM_INITMENUPOPUP, WM_MEASUREITEM, WM_MENUCHAR: HandleContextMenuMsg(Message.Msg, Message.WParam, Message.LParam, Message.Result); end; end; function TNamespace.GetCategoryProviderInterface: ICategoryProvider; begin if not Assigned(FCategoryProviderInterface) and Folder and Assigned(ShellFolder) then begin if not Succeeded(ShellFolder.CreateViewObject(ParentWnd, IID_ICategoryProvider, Pointer(FCategoryProviderInterface))) then FCategoryProviderInterface := nil end; Result := FCategoryProviderInterface end; function TNamespace.CreateCategory(GUID: TGUID): ICategorizer; begin Result := nil; if Assigned(CategoryProviderInterface) then begin if not Succeeded(CategoryProviderInterface.CreateCategory(GUID, IID_ICategorizer, Result)) then Result := nil; end end; function TNamespace.EnumFuncDummy(MessageWnd: HWnd; APIDL: PItemIDList; AParent: TNamespace; Data: Pointer; var Terminate: Boolean): Boolean; begin PIDLMgr.FreePIDL(APIDL); Result := True; end; function TNamespace.GetBrowserFrameOptionsInterface: IBrowserFrameOptions; var Found: Boolean; begin if not Assigned(FBrowserFrameOptionsInterface) then begin Found := False; if Assigned(Parent) then begin Found := Succeeded(Parent.ShellFolder.GetUIObjectOf(ParentWnd, 1, FRelativePIDL, IBrowserFrameOptions, nil, Pointer(FBrowserFrameOptionsInterface))); if not Found and Folder then begin Found := Succeeded(ShellFolder.CreateViewObject(ParentWnd, IBrowserFrameOptions, Pointer(FBrowserFrameOptionsInterface))); if not Found then Found := Succeeded(ShellFolder.QueryInterface(IBrowserFrameOptions, Pointer(FBrowserFrameOptionsInterface))) end end; if not Found then FBrowserFrameOptionsInterface := nil end; Result := FBrowserFrameOptionsInterface end; function TNamespace.GetQueryAssociationsInterface: IQueryAssociations; var Found: Boolean; begin if not Assigned(FQueryAssociationsInterface) then begin Found := False; if Assigned(Parent) then begin Found := Succeeded(Parent.ShellFolder.GetUIObjectOf(ParentWnd, 1, FRelativePIDL, IQueryAssociations, nil, Pointer(FQueryAssociationsInterface))); if not Found and Folder then begin Found := Succeeded(ShellFolder.CreateViewObject(ParentWnd, IQueryAssociations, Pointer(FQueryAssociationsInterface))); if not Found then Found := Succeeded(ShellFolder.QueryInterface(IQueryAssociations, Pointer(FQueryAssociationsInterface))) end end; if not Found then FQueryAssociationsInterface := nil end; Result := FQueryAssociationsInterface end; function TNamespace.GetValid: Boolean; var rgfInOut: UINT; begin // Does not work on floppy drives and such // password proctected network drives also return false regardless if they have // not been logged into yet so return true for those too. if (not Removable and (Assigned(ParentShellFolder))) and not PotentialMappedDrive(Self) then begin rgfInOut := SFGAO_VALIDATE; // This returns false on a password protected network folder Result := ParentShellFolder.GetAttributesOf(1, FRelativePIDL, rgfInOut) = NOERROR end else Result := True end; procedure TNamespace.ReplacePIDL(NewPIDL: PItemIDList; AParent: TNamespace); begin InvalidateNamespace(True); PIDLMgr.FreeAndNilPIDL(FAbsolutePIDL); if Assigned(Parent) then FAbsolutePIDL := PIDLMgr.AppendPIDL(AParent.FAbsolutePIDL, PIDLMgr.CopyPIDL(NewPIDL)) else FAbsolutePIDL := PIDLMgr.CopyPIDL(NewPIDL); FRelativePIDL := PIDLMgr.GetPointerToLastID(FAbsolutePIDL); end; { TExtractImage } constructor TExtractImage.Create; begin FWidth := 200; FHeight := 200; FColorDepth := 32; FFlags := IEIFLAG_SCREEN; end; function TExtractImage.GetImage: TBitmap; function BitsToPixelFormat(Bits: Windows.TBITMAP): TPixelFormat; begin case Bits.bmBitsPixel of 32: Result := pf32Bit; 24: Result := pf24Bit; 16: Result := pf16Bit; 15: Result := pf15Bit; 8: Result := pf8Bit; 4: Result := pf4Bit; 1: Result := pf1Bit; else Result := pfDevice end end; var Bits: HBITMAP; begin Bits := 0; Result := nil; if Assigned(ExtractImageInterface) then if Succeeded(ExtractImageInterface.Extract(Bits)) then begin // Can't just assign the bitmap handle to the canvas because the bitmap // may not be a DIB. If not then if the bitmap is written to as stream then // TBitmap will be created as a DIB when it is read back from the stream and // it will be displayed upside down Result := TBitmap.Create; Result.PixelFormat := pf32Bit; //BitsToPixelFormat(BitInfo); Result.Transparent := True; Result.Handle := Bits; end end; function TExtractImage.GetExtractImageInterface2: IExtractImage2; var Found: Boolean; begin if not Assigned(FExtractImage2Interface) then begin Found := False; if Assigned(ExtractImageInterface) then Found := ExtractImageInterface.QueryInterface(IID_IExtractImage2, Pointer(FExtractImage2Interface)) <> E_NOINTERFACE; if not Found then FExtractImage2Interface := nil end; Result := FExtractImage2Interface end; function TExtractImage.GetExtractImageInterface: IExtractImage; var Found: Boolean; begin if not Assigned(FExtractImageInterface) then begin Found := False; if Assigned(Owner.ParentShellFolder) then begin Found := Owner.ParentShellFolder.GetUIObjectOf(0, 1, Owner.FRelativePIDL, IExtractImage, nil, Pointer(FExtractImageInterface)) = NOERROR; end; if not Found and Assigned(Owner.ShellFolder) then begin Found := Owner.ShellFolder.CreateViewObject(0, IExtractImage, Pointer(FExtractImageInterface)) = NOERROR; end; if not Found then FExtractImageInterface := nil end; Result := FExtractImageInterface end; function TExtractImage.GetImagePath: WideString; var Size: TSize; Buffer: PWideChar; begin if Assigned(ExtractImageInterface) then begin GetMem(Buffer, MAX_PATH * 4); try try Size.cx := Width; Size.cy := Height; if ExtractImageInterface.GetLocation(Buffer, MAX_PATH, FPriority, Size, ColorDepth, FFlags) = NOERROR then begin Result := Buffer; PathExtracted := True end else Result := ''; finally FreeMem(Buffer); end except Result := '' end end; end; { ----------------------------------------------------------------------------- } { Encapsulation of IShellLink } { ----------------------------------------------------------------------------- } { TVirtualShellLink } destructor TVirtualShellLink.Destroy; begin FreeTargetIDList; inherited; end; procedure TVirtualShellLink.FreeTargetIDList; var Malloc: IMalloc; PIDL: PItemIDList; begin if Assigned(TargetIDList) then begin PIDL := TargetIDLIst; TargetIDList := nil; SHGetMalloc(Malloc); Malloc.Free(PIDL); end; end; function TVirtualShellLink.GetShellLinkAInterface: IShellLink; begin if not Assigned(FShellLinkA) then begin if not Succeeded(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IShellLinkA, FShellLinkA)) then FShellLinkA := nil; end; Result := FShellLinkA end; function TVirtualShellLink.GetShellLinkWInterface: IShellLinkW; begin if not Assigned(FShellLinkW) then begin if not Succeeded(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IShellLinkW, FShellLinkW)) then FShellLinkW := nil end; Result := FShellLinkW end; function TVirtualShellLink.ReadLink(LinkFileName: WideString): Boolean; const BUFFERSIZE = 1024; var Success: Boolean; S: string; PersistFile: IPersistFile; pwHotKey: Word; Cmd: integer; FindData: WIN32_FIND_DATA; FindDataW: WIN32_FIND_DATAW; begin Result := False; Success := False; if Assigned(ShellLinkWInterface) then begin if CommonSupports(ShellLinkWInterface, IPersistFile, PersistFile) then begin FFileName := LinkFileName; Success := Succeeded(PersistFile.Load(PWideChar(FileName), STGM_READWRITE)); if Success then begin Result := True; SetLength(FTargetPath, BUFFERSIZE); Success := Succeeded(ShellLinkWInterface.GetPath(PWideChar( FTargetPath), MAX_PATH, FindDataW, SLGP_UNCPRIORITY)); if Success then SetLength(FTargetPath, lstrlenW(PWideChar( FTargetPath))); SetLength(FArguments, BUFFERSIZE); Success := Succeeded(ShellLinkWInterface.GetArguments(PWideChar( FArguments), BUFFERSIZE)); if Success then SetLength(FArguments, lstrlenW(PWideChar( FArguments))); SetLength(FDescription, BUFFERSIZE); Success := Succeeded(ShellLinkWInterface.GetDescription(PWideChar( FDescription), BUFFERSIZE)); if Success then SetLength(FDescription, lstrlenW(PWideChar( FDescription))); SetLength(FWorkingDirectory, BUFFERSIZE); Success := Succeeded(ShellLinkWInterface.GetWorkingDirectory(PWideChar( FWorkingDirectory), BUFFERSIZE)); if Success then SetLength(FWorkingDirectory, lstrlenW(PWideChar( FWorkingDirectory))); SetLength(FIconLocation, BUFFERSIZE); Success := Succeeded(ShellLinkWInterface.GetIconLocation(PWideChar( FIconLocation), BUFFERSIZE, FIconIndex)); if Success then SetLength(FIconLocation, lstrlenW(PWideChar( FIconLocation))); FreeTargetIDList; ShellLinkWInterface.GetIDList(FTargetIDList); Success := Succeeded(ShellLinkWInterface.GetHotKey(pwHotKey)); if Success then begin FHotKey := LoByte(pwHotKey); FHotKeyModifiers := []; if HiByte(pwHotKey) and HOTKEYF_ALT <> 0 then Include(FHotKeyModifiers, hkmAlt); if HiByte(pwHotKey) and HOTKEYF_CONTROL <> 0 then Include(FHotKeyModifiers, hkmControl); if HiByte(pwHotKey) and HOTKEYF_EXT <> 0 then Include(FHotKeyModifiers, hkmExtendedKey); if HiByte(pwHotKey) and HOTKEYF_SHIFT <> 0 then Include(FHotKeyModifiers, hkmShift); end; Success := Succeeded(ShellLinkWInterface.GetShowCmd(Cmd)); if Success then case Cmd of SW_HIDE: ShowCmd := swHide; SW_MAXIMIZE: ShowCmd := swMaximize; SW_MINIMIZE: ShowCmd := swMinimize; SW_RESTORE: ShowCmd := swRestore; SW_SHOW: ShowCmd := swShow; SW_SHOWDEFAULT: ShowCmd := swShowDefault; SW_SHOWMINIMIZED: ShowCmd := swShowMinimized; SW_SHOWMINNOACTIVE: ShowCmd := swShowMinNoActive; SW_SHOWNA : ShowCmd := swShowNA; SW_SHOWNOACTIVATE : ShowCmd := swShowNoActive; SW_SHOWNORMAL: ShowCmd := swShowNormal; end; // Why was that here? Removed 11.12.02 // PersistFile.Save(PWideChar(FileName), True) end else FFileName := '' end end; if not Success and Assigned(ShellLinkAInterface) then begin if CommonSupports(ShellLinkAInterface, IPersistFile, PersistFile) then begin FFileName := LinkFileName; Success := Succeeded(PersistFile.Load(PWideChar(FileName), STGM_READWRITE)); if Success then begin Result := True; SetLength(S, BUFFERSIZE); Success := Succeeded(ShellLinkAInterface.GetPath(PChar( S), MAX_PATH, FindData, SLGP_UNCPRIORITY)); if Success then begin SetLength(S, lstrlen(PChar( S))); FTargetPath := S end; SetLength(S, BUFFERSIZE); Success := Succeeded(ShellLinkAInterface.GetArguments(PChar( S), BUFFERSIZE)); if Success then begin SetLength(S, lstrlen(PChar( S))); FArguments := S end; SetLength(S, BUFFERSIZE); Success := Succeeded(ShellLinkAInterface.GetDescription(PChar( S), BUFFERSIZE)); if Success then begin SetLength(S, lstrlen(PChar( S))); FDescription := S end; SetLength(S, BUFFERSIZE); Success := Succeeded(ShellLinkAInterface.GetWorkingDirectory(PChar( S), BUFFERSIZE)); if Success then begin SetLength(S, lstrlen(PChar( S))); FWorkingDirectory := S end; SetLength(S, BUFFERSIZE); Success := Succeeded(ShellLinkAInterface.GetIconLocation(PChar( S), BUFFERSIZE, FIconIndex)); if Success then begin SetLength(S, lstrlen(PChar( S))); FIconLocation := S end; FreeTargetIDList; ShellLinkAInterface.GetIDList(FTargetIDList); Success := Succeeded(ShellLinkAInterface.GetHotKey(pwHotKey)); if Success then begin FHotKey := LoByte(pwHotKey); FHotKeyModifiers := []; if HiByte(pwHotKey) and HOTKEYF_ALT <> 0 then Include(FHotKeyModifiers, hkmAlt); if HiByte(pwHotKey) and HOTKEYF_CONTROL <> 0 then Include(FHotKeyModifiers, hkmControl); if HiByte(pwHotKey) and HOTKEYF_EXT <> 0 then Include(FHotKeyModifiers, hkmExtendedKey); if HiByte(pwHotKey) and HOTKEYF_SHIFT <> 0 then Include(FHotKeyModifiers, hkmShift); end; Success := Succeeded(ShellLinkAInterface.GetShowCmd(Cmd)); if Success then case Cmd of SW_HIDE: ShowCmd := swHide; SW_MAXIMIZE: ShowCmd := swMaximize; SW_MINIMIZE: ShowCmd := swMinimize; SW_RESTORE: ShowCmd := swRestore; SW_SHOW: ShowCmd := swShow; SW_SHOWDEFAULT: ShowCmd := swShowDefault; SW_SHOWMINIMIZED: ShowCmd := swShowMinimized; SW_SHOWMINNOACTIVE: ShowCmd := swShowMinNoActive; SW_SHOWNA : ShowCmd := swShowNA; SW_SHOWNOACTIVATE : ShowCmd := swShowNoActive; SW_SHOWNORMAL: ShowCmd := swShowNormal; end; PersistFile.Save(PWideChar(FileName), True) end else FFileName := ''; end end end; function TVirtualShellLink.WriteLink(LinkFileName: WideString): Boolean; var S: string; PersistFile: IPersistFile; pwHotKey, pwHotKeyHi: Word; KeyModifier: THotKeyModifiers; Cmd: integer; begin Result := False; if (TargetPath = '') and not Assigned(TargetIDList) and not SilentWrite then WideShowMessage(Application.Handle, STR_NOTARGETDEFINED, STR_ERROR) else begin if Assigned(ShellLinkWInterface) then begin if CommonSupports(ShellLinkWInterface, IPersistFile, PersistFile) then begin FFileName := LinkFileName; ShellLinkWInterface.SetPath(PWideChar( FTargetPath)); ShellLinkWInterface.SetArguments(PWideChar( FArguments)); ShellLinkWInterface.SetDescription(PWideChar( FDescription)); ShellLinkWInterface.SetPath(PWideChar( FTargetPath)); ShellLinkWInterface.SetWorkingDirectory(PWideChar( FWorkingDirectory)); ShellLinkWInterface.SetIconLocation(PWideChar( FIconLocation), FIconIndex); if Assigned(FTargetIDList) then ShellLinkWInterface.SetIDList(FTargetIDList); pwHotKey := HotKey; pwHotKeyHi := 0; KeyModifier := HotKeyModifiers; if hkmAlt in KeyModifier then pwHotKeyHi := pwHotKeyHi or HOTKEYF_ALT; if hkmControl in KeyModifier then pwHotKeyHi := pwHotKeyHi or HOTKEYF_CONTROL; if hkmExtendedKey in KeyModifier then pwHotKeyHi := pwHotKeyHi or HOTKEYF_EXT; if hkmShift in KeyModifier then pwHotKeyHi := pwHotKeyHi or HOTKEYF_SHIFT; pwHotKeyHi := pwHotKeyHi shl 8; // Make lower 8 bits the upper 8 bits pwHotKeyHi := pwHotKeyHi and $FF00; // Make sure lower 8 bits clear pwHotKey := pwHotKey or pwHotKeyHi; ShellLinkWInterface.SetHotkey(pwHotKey); case ShowCmd of swHide: Cmd := SW_HIDE; swMaximize: Cmd := SW_MAXIMIZE; swMinimize: Cmd := SW_MINIMIZE; swRestore: Cmd := SW_RESTORE; swShow: Cmd := SW_SHOW; swShowDefault: Cmd := SW_SHOWDEFAULT; swShowMinimized: Cmd := SW_SHOWMINIMIZED; swShowMinNoActive: Cmd := SW_SHOWMINNOACTIVE; swShowNA: Cmd := SW_SHOWNA; swShowNoActive: Cmd := SW_SHOWNOACTIVATE; swShowNormal: Cmd := SW_SHOWNORMAL; else Cmd := SW_SHOWNORMAL end; ShellLinkWInterface.SetShowCmd(Cmd); Result := Succeeded(PersistFile.Save(PWideChar(FileName), True)) end; end; if not Result and Assigned(ShellLinkAInterface) then begin if CommonSupports(ShellLinkAInterface, IPersistFile, PersistFile) then begin FFileName := LinkFileName; S := FTargetPath; ShellLinkAInterface.SetPath(PChar( S)); S := FArguments; ShellLinkAInterface.SetArguments(PChar(S)); S := FDescription; ShellLinkAInterface.SetDescription(PChar( S)); S := FTargetPath; ShellLinkAInterface.SetPath(PChar( S)); S := FWorkingDirectory; ShellLinkAInterface.SetWorkingDirectory(PChar( S)); S := FIconLocation; ShellLinkAInterface.SetIconLocation(PChar( S), FIconIndex); if Assigned(FTargetIDList) then ShellLinkAInterface.SetIDList(FTargetIDList); pwHotKey := HotKey; pwHotKeyHi := 0; KeyModifier := HotKeyModifiers; if hkmAlt in KeyModifier then pwHotKeyHi := pwHotKeyHi or HOTKEYF_ALT; if hkmControl in KeyModifier then pwHotKeyHi := pwHotKeyHi or HOTKEYF_CONTROL; if hkmExtendedKey in KeyModifier then pwHotKeyHi := pwHotKeyHi or HOTKEYF_EXT; if hkmShift in KeyModifier then pwHotKeyHi := pwHotKeyHi or HOTKEYF_SHIFT; pwHotKeyHi := pwHotKeyHi shl 8; // Make lower 8 bits the upper 8 bits pwHotKeyHi := pwHotKeyHi and $FF00; // Make sure lower 8 bits clear pwHotKey := pwHotKey or pwHotKeyHi; ShellLinkAInterface.SetHotkey(pwHotKey); case ShowCmd of swHide: Cmd := SW_HIDE; swMaximize: Cmd := SW_MAXIMIZE; swMinimize: Cmd := SW_MINIMIZE; swRestore: Cmd := SW_RESTORE; swShow: Cmd := SW_SHOW; swShowDefault: Cmd := SW_SHOWDEFAULT; swShowMinimized: Cmd := SW_SHOWMINIMIZED; swShowMinNoActive: Cmd := SW_SHOWMINNOACTIVE; swShowNA: Cmd := SW_SHOWNA; swShowNoActive: Cmd := SW_SHOWNOACTIVATE; swShowNormal: Cmd := SW_SHOWNORMAL; else Cmd := SW_SHOWNORMAL end; ShellLinkAInterface.SetShowCmd(Cmd); Result := Succeeded(PersistFile.Save(PWideChar(FileName), True)) end end end end; { ----------------------------------------------------------------------------- } { TList that implements basic streaming } { ----------------------------------------------------------------------------- } { TStreamableList } constructor TStreamableList.Create; begin FStreamVersion := STREAM_VERSION_DEFAULT end; procedure TStreamableList.LoadFromFile(FileName: WideString; Version: integer = 0; ReadVerFromStream: Boolean = False); var {$IFDEF TNTSUPPORT} FileStream: TTntFileStream; {$ELSE} FileStream: TFileStream; {$ENDIF} begin FileStream := nil; try {$IFDEF TNTSUPPORT} FileStream := TTntFileStream.Create(FileName, fmOpenRead or fmShareExclusive); {$ELSE} FileStream := TFileStream.Create(FileName, fmOpenRead or fmShareExclusive); {$ENDIF} LoadFromStream(FileStream); finally FileStream.Free end; end; procedure TStreamableList.LoadFromStream(S: TStream; Version: integer; ReadVerFromStream: Boolean); begin Clear; if ReadVerFromStream then S.ReadBuffer(FStreamVersion, Sizeof(FStreamVersion)) else FStreamVersion := Version; end; procedure TStreamableList.SaveToFile(FileName: WideString; Version: integer = 0; ReadVerFromStream: Boolean = False); var {$IFDEF TNTSUPPORT} FileStream: TTntFileStream; {$ELSE} FileStream: TFileStream; {$ENDIF} begin FileStream := nil; try {$IFDEF TNTSUPPORT} FileStream := TTntFileStream.Create(FileName, fmCreate or fmShareExclusive); {$ELSE} FileStream := TFileStream.Create(FileName, fmCreate or fmShareExclusive); {$ENDIF} SaveToStream(FileStream); finally FileStream.Free end; end; procedure TStreamableList.SaveToStream(S: TStream; Version: integer; WriteVerToStream: Boolean); begin if WriteVerToStream then S.WriteBuffer(Version, Sizeof(Version)); FStreamVersion := Version; end; { ----------------------------------------------------------------------------- } { TClass that implements basic streaming } { ----------------------------------------------------------------------------- } { TStreamableClass } constructor TStreamableClass.Create; begin FStreamVersion := STREAM_VERSION_DEFAULT end; procedure TStreamableClass.LoadFromFile(FileName: WideString; Version: integer = 0; ReadVerFromStream: Boolean = False); var {$IFDEF TNTSUPPORT} FileStream: TTntFileStream; {$ELSE} FileStream: TFileStream; {$ENDIF} begin FileStream := nil; try {$IFDEF TNTSUPPORT} FileStream := TTntFileStream.Create(FileName, fmOpenRead or fmShareExclusive); {$ELSE} FileStream := TFileStream.Create(FileName, fmOpenRead or fmShareExclusive); {$ENDIF} LoadFromStream(FileStream, Version, ReadVerFromStream); finally FileStream.Free end; end; procedure TStreamableClass.LoadFromStream(S: TStream; Version: integer; ReadVerFromStream: Boolean); begin if ReadVerFromStream then S.ReadBuffer(FStreamVersion, Sizeof(FStreamVersion)) else FStreamVersion := Version; end; procedure TStreamableClass.SaveToFile(FileName: WideString; Version: integer = 0; ReadVerFromStream: Boolean = False); var {$IFDEF TNTSUPPORT} FileStream: TTntFileStream; {$ELSE} FileStream: TFileStream; {$ENDIF} begin FileStream := nil; try {$IFDEF TNTSUPPORT} FileStream := TTntFileStream.Create(FileName, fmCreate or fmShareExclusive); {$ELSE} FileStream := TFileStream.Create(FileName, fmCreate or fmShareExclusive); {$ENDIF} SaveToStream(FileStream, Version, ReadVerFromStream); finally FileStream.Free end; end; procedure TStreamableClass.SaveToStream(S: TStream; Version: integer; WriteVerToStream: Boolean); begin if WriteVerToStream then S.WriteBuffer(Version, Sizeof(Version)); FStreamVersion := Version; end; { ----------------------------------------------------------------------------- } { Class that frees it self when the reference count goes to 0. Like a com } { object but the compiler does not inc/dec automaticlly } { ----------------------------------------------------------------------------- } { TReferenceCounted } procedure TReferenceCounted.AddRef; begin InterlockedIncrement(FRefCount) end; procedure TReferenceCounted.Release; begin InterlockedDecrement (FRefCount); if FRefCount <= 0 then Free; end; { ----------------------------------------------------------------------------- } { TList that frees it self when the reference count goes to 0. Like a com } { object but the compiler does not inc/dec automaticlly } { ----------------------------------------------------------------------------- } { TReferenceCountedList } procedure TReferenceCountedList.AddRef; begin InterlockedIncrement(FRefCount) end; procedure TReferenceCountedList.Release; begin InterlockedDecrement (FRefCount); if FRefCount <= 0 then Free; end; { TShellSortHelper } function TShellSortHelper.CompareIDSort(SortColumn: integer; NS1, NS2: TNamespace): Integer; begin if Assigned(NS1.ParentShellFolder) then begin Result := NS2.ComparePIDL(NS1.RelativePIDL, False, SortColumn); { If we are not sorting the Name column then do a sub-sort on the name if } { the items are equal. } if (SortColumn > 0) and (Result = 0) then Result := WideCompareText(NS1.NameInFolder, NS2.NameInFolder) end else Result := 0; end; function TShellSortHelper.DiscriminateFolders(NS1, NS2: TNamespace): Integer; begin Result := 0; if NS1.Folder xor NS2.Folder then begin if NS1.Folder and not NS2.Folder then Result := -1 else if not NS1.Folder and NS2.Folder then Result := 1 end end; function TShellSortHelper.SortFileSize(NS1, NS2: TNamespace): Integer; begin Result := DiscriminateFolders(NS1, NS2); if Result = 0 then begin if NS1.SizeOfFileInt64 > NS2.SizeOfFileInt64 then Result := 1 else if NS1.SizeOfFileInt64 < NS2.SizeOfFileInt64 then Result := -1 else Result := CompareIDSort(0, NS1, NS2) end end; function TShellSortHelper.SortFileTime(FT1, FT2: TFileTime; NS1, NS2: TNamespace): Integer; begin Result := DiscriminateFolders(NS1, NS2); if Result = 0 then begin Result := CompareFileTime(FT1, FT2); if Result = 0 then Result := CompareIDSort(0, NS1, NS2) end end; function TShellSortHelper.SortString(S1, S2: WideString; NS1, NS2: TNamespace): Integer; begin Result := DiscriminateFolders(NS1, NS2); if Result = 0 then begin Result := WideCompareText(S1, S2); if Result = 0 then Result := CompareIDSort(0, NS1, NS2) end end; function TShellSortHelper.SortType(NS1, NS2: TNamespace): Integer; begin if FileSort = fsFileType then Result := SortString(NS1.FileType, NS2.FileType, NS1, NS2) else begin { Must be fsFileExtension } Result := DiscriminateFolders(NS1, NS2); if Result = 0 then begin if NS1.FileSystem and NS2.FileSystem then begin Result := SortString(ExtractFileExt(NS1.NameParseAddress), ExtractFileExt(NS2.NameParseAddress), NS1, NS2); if Result = 0 then CompareIDSort(0, NS1, NS2); // Secondary sort end; end end end; {$IFNDEF COMPILER_5_UP} { TObjectList } function TObjectList.Add(AObject: TObject): Integer; begin Result := inherited Add(AObject); end; constructor TObjectList.Create; begin inherited Create; FOwnsObjects := True; end; constructor TObjectList.Create(AOwnsObjects: Boolean); begin inherited Create; FOwnsObjects := AOwnsObjects; end; function TObjectList.FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt: Integer): Integer; var I: Integer; begin Result := -1; for I := AStartAt to Count - 1 do if (AExact and (Items[I].ClassType = AClass)) or (not AExact and Items[I].InheritsFrom(AClass)) then begin Result := I; break; end; end; function TObjectList.First: TObject; begin Result := TObject(inherited First); end; function TObjectList.GetItem(Index: Integer): TObject; begin Result := inherited Items[Index]; end; function TObjectList.IndexOf(AObject: TObject): Integer; begin Result := inherited IndexOf(AObject); end; procedure TObjectList.Insert(Index: Integer; AObject: TObject); begin inherited Insert(Index, AObject); end; function TObjectList.Last: TObject; begin Result := TObject(inherited Last); end; function TObjectList.Remove(AObject: TObject): Integer; begin Result := inherited Remove(AObject); end; procedure TObjectList.SetItem(Index: Integer; AObject: TObject); begin inherited Items[Index] := AObject; end; {$ENDIF} { TVirtualNamespaceList } function TVirtualNamespaceList.Add(ANamespace: TNamespace): Integer; begin Result := inherited Add(ANamespace); end; procedure TVirtualNamespaceList.FillArray(var NamespaceArray: TNamespaceArray); var I: Integer; begin SetLength(NamespaceArray, Count); for I := 0 to Count - 1 do NamespaceArray[0] := Items[I]; end; function TVirtualNamespaceList.GetItems(Index: Integer): TNamespace; begin Result := TNamespace(inherited Items[Index]); end; function TVirtualNamespaceList.IndexOf(ANamespace: TNamespace): Integer; begin Result := inherited IndexOf(ANamespace); end; procedure TVirtualNamespaceList.Insert(Index: Integer; ANamespace: TNamespace); begin inherited Insert(Index, ANamespace); end; procedure TVirtualNamespaceList.SetItems(Index: Integer; ANamespace: TNamespace); begin inherited Items[Index] := ANamespace; end; { TCommonShellContextMenu } constructor TCommonShellContextMenu.Create(AOwner: TComponent); begin inherited; {$IFDEF TNTSUPPORT} KeyStrings := TTntStringList.Create; {$ELSE} KeyStrings := TStringList.Create; {$ENDIF} MenuMap := TMenuItemMap.Create; KeyStrings.Duplicates := dupIgnore; KeyStrings.Sorted := True; Stub := CreateStub(Self, @TCommonShellContextMenu.DefMenuCreateCallback); FRenameMenuItem := True; FPasteMenuItem := True; end; destructor TCommonShellContextMenu.Destroy; begin DisposeStub(Stub); FreeAndNil(FKeyStrings); inherited Destroy; end; function TCommonShellContextMenu.BindToObject(pidl: PItemIDList; pbcReserved: Pointer; const riid: TIID; out ppvOut{$IFNDEF COMPILER_5_UP}: Pointer{$ENDIF}): HResult; begin Result := ActiveFolder.BindToObject(pidl, pbcReserved, riid, ppvOut); {$IFDEF GXDEBUG_VIRTUALCONTEXTMENU} SendDebug('BindToObject - Result = ' + InttoStr(Result)); {$ENDIF} end; function TCommonShellContextMenu.BindToStorage(pidl: PItemIDList; pbcReserved: Pointer; const riid: TIID; out ppvObj{$IFNDEF COMPILER_5_UP}: Pointer{$ENDIF}): HResult; begin Result := ActiveFolder.BindToStorage(pidl, pbcReserved, riid, ppvObj); {$IFDEF GXDEBUG_VIRTUALCONTEXTMENU} SendDebug('BindToStorage - Result = ' + InttoStr(Result)); {$ENDIF} end; function TCommonShellContextMenu.CompareIDs(lParam: LPARAM; pidl1, pidl2: PItemIDList): HResult; begin Result := ActiveFolder.CompareIDs(lParam, pidl1, pidl2); {$IFDEF GXDEBUG_VIRTUALCONTEXTMENU} SendDebug('CompareIDs - Result = ' + InttoStr(Result)); {$ENDIF} end; function TCommonShellContextMenu.CreateViewObject(hwndOwner: HWND; const riid: TIID; out ppvOut{$IFNDEF COMPILER_5_UP}: Pointer{$ENDIF}): HResult; begin Result := ActiveFolder.CreateViewObject(hwndOwner, riid, ppvOut); {$IFDEF GXDEBUG_VIRTUALCONTEXTMENU} SendDebug('CreateViewObject - Result = ' + InttoStr(Result)); {$ENDIF} end; function TCommonShellContextMenu.DefMenuCreateCallback(const psf: IShellfolder; wnd: HWND; const pdtObj: IDataObject; uMsg: UINT; WParm: WParam; lParm: LParam): HResult; var DoDefault: Boolean; IDO: IDataObject; QCMInfo: PQCMINFO; DFMICS: PDFMICS; MapCount, i: Integer; MergeOffset: UINT; {$IFDEF TNTSUPPORT} MenuItem: TTntMenuItem; {$ELSE} MenuItem: TMenuItem; {$ENDIF} begin Result := E_NOTIMPL; DoDefault := True; case uMsg of DFM_MERGECONTEXTMENU: begin if cmeShellDefault in Extensions then Result := S_OK else Result := S_FALSE; QCMInfo := PQCMINFO( lParm); // This seems to be broken. The items added "normally" (using idCmdFirst as is) // don't get registered and send a 0 when selected. DFM_MERGECONTEXTMENUTOP works // but the return in DFM_INVOKECOMMAND is the OFFSET of the idCmdFirst passed // so we have to make sure that the offset does not overlap the idCmdFirst we // use here so choose a large enough number. If we increase idCmdFirst from // its passed value it seems to make it work and in DFM_INVOKECOMMAND we get that // the (Value - 1) rather then then Offset. MapCount := MenuMap.Count; MergeOffset := QCMInfo^.idCmdFirst; QCMInfo^.idCmdFirst := QCMInfo^.idCmdFirst + 200; // Allow up to 200 items to be added in DFM_MERGECONTEXTMENUTOP; DoMenuMerge(QCMInfo^.Menu, QCMInfo^.IndexMenu, QCMInfo^.idCmdFirst, QCMInfo^.idCmdLast, CFM_FLAGSToShellContextMenuFlags(WParm)); // Fix the MenuIDs to be commonly offset once all merging is done if MenuMap.Count > MapCount then for i := MapCount to MenuMap.Count - 1 do MenuMap[i].MenuID := MenuMap[i].MenuID - MergeOffset; {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_MERGECONTEXTMENU'); {$ENDIF} end; DFM_INVOKECOMMAND: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_INVOKECOMMAND'); {$ENDIF} case Cardinal( wParm) of DFM_CMD_DELETE: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_INVOKECOMMAND: DFM_CMD_DELETE'); {$ENDIF} DoDelete(psf, pdtObj, DoDefault); end; DFM_CMD_CUT: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_INVOKECOMMAND: DFM_CMD_CUT'); {$ENDIF} DoCut(psf, pdtObj, DoDefault) end; DFM_CMD_COPY: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_INVOKECOMMAND: DFM_CMD_COPY'); {$ENDIF} DoCopy(psf, pdtObj, DoDefault) end; DFM_CMD_CREATESHORTCUT: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_INVOKECOMMAND: DFM_CMD_CREATESHORTCUT'); {$ENDIF} DoCreateShortCut(psf, pdtObj, DoDefault) end; DFM_CMD_PROPERTIES: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_INVOKECOMMAND: DFM_CMD_PROPERTIES'); {$ENDIF} DoProperties(psf, pdtObj, DoDefault); if DoDefault and not IsWinVistaOrUp then begin if Assigned(SHMultiFileProperties_MP) then begin CreateFullyQualifiedShellDataObject(NamespaceToAbsolutePIDLArray(LocalNamespaces), IDO); if Assigned(IDO) then SHMultiFileProperties_MP(IDO, 0); // Not sure why I have to do this but I have to in order for the counting to work right.. IDO._Release; end else DesktopFolder.ShowPropertySheetMulti(LocalNamespaces, False, True); DoDefault := False end end; DFM_CMD_NEWFOLDER: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_INVOKECOMMAND: DFM_CMD_NEWFOLDER'); {$ENDIF} DoNewFolder(psf, pdtObj, DoDefault) end; DFM_CMD_PASTE: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_INVOKECOMMAND: DFM_CMD_PASTE'); {$ENDIF} DoPaste(psf, pdtObj, DoDefault) end; DFM_CMD_VIEWLIST: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_INVOKECOMMAND: DFM_CMD_VIEWLIST'); {$ENDIF} end; DFM_CMD_VIEWDETAILS: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_INVOKECOMMAND: DFM_CMD_VIEWDETAILS'); {$ENDIF} end; DFM_CMD_PASTELINK: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_INVOKECOMMAND: DFM_CMD_PASTELINK'); {$ENDIF} DoPasteLink(psf, pdtObj, DoDefault) end; DFM_CMD_PASTESPECIAL: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_INVOKECOMMAND: DFM_CMD_PasteShortCut'); {$ENDIF} DoPasteShortCut(psf, pdtObj, DoDefault) end; DFM_CMD_MODALPROP: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_INVOKECOMMAND: DFM_CMD_MODALPROP'); {$ENDIF} end; end; if DoDefault then Result := S_FALSE else Result := S_OK end; DFM_CREATE: begin DoShow; {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_CREATE'); {$ENDIF} end; DFM_DESTROY: begin DoHide; {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_DESTROY'); {$ENDIF} end; DFM_GETHELPTEXTA: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_GETHELPTEXTA'); {$ENDIF} end; DFM_MEASUREITEM: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_MEASUREITEM'); {$ENDIF} end; DFM_DRAWITEM: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_DRAWITEM'); {$ENDIF} end; DFM_INITMENUPOPUP: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_INITMENUPOPUP'); {$ENDIF} end; DFM_VALIDATECMD: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_VALIDATECMD'); {$ENDIF} end; DFM_MERGECONTEXTMENU_TOP: begin if cmeShellDefault in Extensions then Result := S_OK else Result := S_FALSE; QCMInfo := PQCMINFO( lParm); // This seems to be broken. The items added "normally" (using idCmdFirst as is) // don't get registered and send a 0 when selected. DFM_MERGECONTEXTMENUTOP works // but the return in DFM_INVOKECOMMAND is the OFFSET of the idCmdFirst passed // so we have to make sure that the offset does not overlap the idCmdFirst we // use here so choose a large enough number. If we increase idCmdFirst from // its passed value it seems to make it work and in DFM_INVOKECOMMAND we get that // the (Value - 1) rather then then Offset. MapCount := MenuMap.Count; MergeOffset := QCMInfo^.idCmdFirst; QCMInfo^.idCmdFirst := QCMInfo^.idCmdFirst + 600; // Allow up to 200 items to be added in DFM_MERGECONTEXTMENU; DoMenuMergeTop(QCMInfo^.Menu, QCMInfo^.IndexMenu, QCMInfo^.idCmdFirst, QCMInfo^.idCmdLast, CFM_FLAGSToShellContextMenuFlags(WParm)); DoMenuMergeBottom(QCMInfo^.Menu, GetMenuItemCount(QCMInfo^.Menu), QCMInfo^.idCmdFirst, QCMInfo^.idCmdLast, CFM_FLAGSToShellContextMenuFlags(WParm)); // Fix the MenuIDs to be commonly offset once all merging is done if MenuMap.Count > MapCount then for i := MapCount to MenuMap.Count - 1 do MenuMap[i].MenuID := MenuMap[i].MenuID - MergeOffset; {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_MERGECONTEXTMENU_TOP'); {$ENDIF} end; DFM_MERGECONTEXTMENU_BOTTOM: begin // Only works in XP and up. Faked in DFM_MERGECONTEXTMENU_TOP if cmeShellDefault in Extensions then Result := S_OK else Result := S_FALSE; {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_MERGECONTEXTMENU_BOTTOM'); {$ENDIF} end; DFM_GETHELPTEXTW: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_GETHELPTEXTW'); {$ENDIF} end; DFM_INVOKECOMMANDEX: begin DFMICS := PDFMICS( lparm); if FindCommandId(wParm, MenuItem) then DoInvokeCommand(MenuItem, DFMICS^.pici); {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_INVOKECOMMANDEX'); {$ENDIF} end; DFM_MAPCOMMANDNAME: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_MAPCOMMANDNAME'); {$ENDIF} end; DFM_GETDEFSTATICID: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_GETDEFSTATICID'); {$ENDIF} end; DFM_GETVERBW: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_GETVERBW'); {$ENDIF} end; DFM_GETVERBA: begin {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('DFM_GETVERBA'); {$ENDIF} end; else {$IFDEF GXDEBUG_DEFMENUCREATE_CALLBACK} SendDebug('Undefined: ' + IntToStr(UMsg)); {$ENDIF} end; end; function TCommonShellContextMenu.DragEnter(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; begin Result := S_OK; {$IFDEF GXDEBUG_VIRTUALCONTEXTMENU} SendDebug('DragEnter - Result = ' + InttoStr(Result)); {$ENDIF} end; function TCommonShellContextMenu.DragLeave: HResult; begin Result := S_OK; {$IFDEF GXDEBUG_VIRTUALCONTEXTMENU} SendDebug('DragLeave - Result = ' + InttoStr(Result)); {$ENDIF} end; function TCommonShellContextMenu.DragOver(grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; begin Result := E_NOTIMPL; {$IFDEF GXDEBUG_VIRTUALCONTEXTMENU} SendDebug('DragOver - Result = ' + InttoStr(Result)); {$ENDIF} end; function TCommonShellContextMenu.Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; begin Result := E_NOTIMPL; {$IFDEF GXDEBUG_VIRTUALCONTEXTMENU} SendDebug('Drop - Result = ' + InttoStr(Result)); {$ENDIF} end; function TCommonShellContextMenu.DuplicateKey(Key: HKEY): HKEY; begin if Assigned(RegOpenKeyExW_MP) then RegOpenKeyExW_MP(Key, '', 0, MAXIMUM_ALLOWED, Result) else RegOpenKeyExA(Key, '', 0, MAXIMUM_ALLOWED, Result) end; function TCommonShellContextMenu.EnumObjects(hwndOwner: HWND; grfFlags: DWORD; out EnumIDList: IEnumIDList): HResult; begin Result := ActiveFolder.EnumObjects(hwndOwner, grfFlags, EnumIDList); {$IFDEF GXDEBUG_VIRTUALCONTEXTMENU} SendDebug('EnumObjects - Result = ' + InttoStr(Result)); {$ENDIF} end; {$IFDEF TNTSUPPORT} function TCommonShellContextMenu.FindCommandId(CmdID: UINT; var MenuItem: TTntMenuItem): Boolean; var i: Integer; begin Result := False; MenuItem := nil; i := 0; while not Result and (i < MenuMap.Count) do begin Result := MenuMap[i].MenuID = CmdID; if Result then MenuItem := MenuMap[i].Item else Inc(i) end end; {$ELSE} function TCommonShellContextMenu.FindCommandId(CmdID: UINT; var MenuItem: TMenuItem): Boolean; var i: Integer; begin Result := False; MenuItem := nil; i := 0; while not Result and (i < MenuMap.Count) do begin Result := MenuMap[i].MenuID = CmdID; if Result then MenuItem := MenuMap[i].Item else Inc(i) end end; {$ENDIF} function TCommonShellContextMenu.GetAttributesOf(cidl: UINT; var apidl: PItemIDList; var rgfInOut: UINT): HResult; var RequestedFlags: UINT; begin RequestedFlags := rgfInOut; Result := ActiveFolder.GetAttributesOf(cidl, apidl, rgfInOut); if RequestedFlags and SFGAO_CANCOPY <> 0 then if CopyValidated then rgfInOut := rgfInOut or SFGAO_CANCOPY; if RequestedFlags and SFGAO_CANMOVE <> 0 then if CutValidated then rgfInOut := rgfInOut or SFGAO_CANMOVE; end; function TCommonShellContextMenu.GetDisplayNameOf(pidl: PItemIDList; uFlags: DWORD; var lpName: TStrRet): HResult; begin Result := ActiveFolder.GetDisplayNameOf(pidl, uFlags, lpName); {$IFDEF GXDEBUG_VIRTUALCONTEXTMENU} SendDebug('GetDisplayNameOf - Result = ' + InttoStr(Result)); {$ENDIF} end; function TCommonShellContextMenu.GetUIObjectOf(hwndOwner: HWND; cidl: UINT; var apidl: PItemIDList; const riid: TIID; prgfInOut: Pointer; out ppvOut{$IFNDEF COMPILER_5_UP}: Pointer{$ENDIF}): HResult; var DataObject: IDataObject; begin Result := E_NOINTERFACE; if FromDesktop then begin // Need to create a correctly defined fully qualified HDROP in the DataObject if IsEqualGUID(riid, IDataObject) then begin DataObject := nil; CreateFullyQualifiedShellDataObject(ActivePIDLs, DataObject); IDataObject( ppvOut) := DataObject; UIObjectOfDataObject := IDataObject( ppvOut); if Assigned(IDataObject( ppvOut)) then Result := S_OK end else if IsEqualGUID(riid, IDropTarget) then begin if PasteMenuItem then begin // Need to support this to get a Paste menu item IDropTarget( ppvOut) := Self; UIObjectOfDropTarget := IDropTarget( ppvOut); Result := S_OK end end else Result := ActiveFolder.GetUIObjectOf(hwndOwner, cidl, apidl, riid, prgfInOut, ppvOut) end else Result := ActiveFolder.GetUIObjectOf(hwndOwner, cidl, apidl, riid, prgfInOut, ppvOut); {$IFDEF GXDEBUG_VIRTUALCONTEXTMENU} SendDebug('GetUIObjectOf - Result = ' + InttoStr(Result)); {$ENDIF} end; function TCommonShellContextMenu.ParseDisplayName(hwndOwner: HWND; pbcReserved: Pointer; lpszDisplayName: POLESTR; out pchEaten: ULONG; out ppidl: PItemIDList; var dwAttributes: ULONG): HResult; begin Result := ActiveFolder.ParseDisplayName(hwndOwner, pbcReserved, lpszDisplayName, pchEaten, ppidl, dwAttributes); {$IFDEF GXDEBUG_VIRTUALCONTEXTMENU} SendDebug('ParseDisplayName - Result = ' + InttoStr(Result)); {$ENDIF} end; function TCommonShellContextMenu.SetNameOf(hwndOwner: HWND; pidl: PItemIDList; lpszName: POLEStr; uFlags: DWORD; var ppidlOut: PItemIDList): HResult; begin Result := ActiveFolder.SetNameOf(hwndOwner, pidl, lpszName, uFlags, ppidlOut); {$IFDEF GXDEBUG_VIRTUALCONTEXTMENU} SendDebug('SetNameOf - Result = ' + InttoStr(Result)); {$ENDIF} end; function TCommonShellContextMenu.InternalShowContextMenu(Owner: TWinControl; ParentPIDL: PItemIDList; ChildPIDLs: TAbsolutePIDLArray; Verb: WideString; Position: PPoint = nil): Boolean; // // If ParentPIDL is nil the assumption is that the Parent is the // Desktop and the PIDLs are fully qualified PIDLs. If ParentPIDL is assigned then // the PIDLs MUST be immediate children of the ParentPIDL // const MaxVerbLen = 128; type THKeyArray = array of HKey; procedure AddKey(Key: HKey; var KeyArray: THKeyArray); begin SetLength(KeyArray, Length(KeyArray) + 1); KeyArray[Length(KeyArray)-1] := Key end; var Menu: hMenu; InvokeInfo: TCMInvokeCommandInfoEx; MenuCmd: Cardinal; x, y, i: integer; VerbA: string; VerbW: WideString; GenericVerb: Pointer; Handled, AllowShow, Success: Boolean; Flags: Longword; ContextMenu: IContextMenu; ContextMenu2: IContextMenu2; ContextMenu3: IContextMenu3; OldMode: UINT; Keys: THKeyArray; Desktop: IShellFolder; DesktopPIDL, ChildrenPIDLs: PItemIDList; {$IFDEF TNTSUPPORT} Reg: TTntRegistry; {$ELSE} Reg: TRegistry; {$ENDIF} WS, CurVer: WideString; UnknownAdded: Boolean; begin Result := False; DesktopPIDL := nil; Desktop := nil; begin OldMode := SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOOPENFILEERRORBOX); try try Result := False; Assert(Assigned(Owner), 'To show a Context Menu using TNamespace you must pass a valid Owner TWinControl'); if Assigned(Owner) then begin if Assigned(CDefFolderMenu_Create2_MP) then begin FOldWndProcForContextMenu := Owner.WindowProc; try // Hook the owner for the Window message for owner draw menus like // Send To.. Owner.WindowProc := WindowProcForContextMenu; ContextMenu := nil; ContextMenu2 := nil; ContextMenu3 := nil; Result := False; if Assigned(Position) then begin x := Position.x; y := Position.y end else begin x := Mouse.CursorPos.X; // Snag these fast. The mouse can move a fair amount y := Mouse.CursorPos.Y; // before the popup menu is shown. end; FillChar(InvokeInfo, SizeOf(InvokeInfo), #0); Menu := CreatePopupMenu; try Flags := CMF_NORMAL or CMF_EXPLORE; if RenameMenuItem then Flags := Flags or CMF_CANRENAME; if GetKeyState(VK_SHIFT) and $8000 <> 0 then Flags := Flags or CMF_EXTENDEDVERBS; if cmeDirectory in Extensions then AddMenuKey('Directory'); if cmeDirBackground in Extensions then AddMenuKey('Directory\Background'); if cmeFolder in Extensions then AddMenuKey('Folder'); if cmeAsterik in Extensions then AddMenuKey('*'); if cmeAllFilesystemObjects in Extensions then AddMenuKey('AllFilesystemObjects'); // Need to rework this to do it right // 1) look at the extension under HKCR, read default value // 2) open key pointed to by above default value (file class) // 3) see if file class has a "CurVer" key // 4) if so open that key as the current version of the file class // 5) open HKCR/SystemFileAssociations for the file extension // 6) if 1 was unsuccessful (no association) use the "Unknown" key // 7) see if the extension or file class key have \PerceivedType key // 8) if so look in HKCR/SystemFileAssociations for a key of the perceived type from above // // Aug 25th - If I just pass the ext OR the file class then the Merge Extended items works ("Open" for instance) UnknownAdded := False; {$IFDEF TNTSUPPORT} Reg := TTntRegistry.Create; {$ELSE} Reg := TRegistry.Create; {$ENDIF} try Reg.RootKey := HKEY_CLASSES_ROOT; for i := 0 to KeyStrings.Count - 1 do begin if (KeyStrings[i] <> '') then begin if Reg.OpenKeyReadOnly(KeyStrings[i]) then begin // The extension key is open {.ext} AddKey(DuplicateKey(Reg.CurrentKey), Keys); WS := Reg.ReadString(''); Reg.CloseKey; if WS <> '' then begin if Reg.OpenKeyReadOnly(WS) then begin // The FileClass is open, see if there is mulitiple version and a current version if Reg.KeyExists('CurVer') then begin if Reg.OpenKeyReadOnly('CurVer') then begin CurVer := Reg.ReadString(''); if Reg.OpenKeyReadOnly('\' + CurVer) then AddKey(DuplicateKey(Reg.CurrentKey), Keys); end; Reg.CloseKey; end else begin AddKey(DuplicateKey(Reg.CurrentKey), Keys); Reg.CloseKey; end end end end else begin if not UnknownAdded and Reg.OpenKeyReadOnly('Unknown') then begin AddKey(DuplicateKey(Reg.CurrentKey), Keys); Reg.CloseKey; UnknownAdded := True end end; if cmeFileSystemAssociations in Extensions then begin if Reg.OpenKeyReadOnly('SystemFileAssociations\' + KeyStrings[i]) then begin AddKey(DuplicateKey(Reg.CurrentKey), Keys); Reg.CloseKey; end end; if cmePerceivedType in Extensions then begin if Reg.OpenKeyReadOnly(KeyStrings[i]) then begin WS := Reg.ReadString('PerceivedType'); if WS <> '' then begin if Reg.OpenKeyReadOnly('\SystemFileAssociations\' + WS) then AddKey(DuplicateKey(Reg.CurrentKey), Keys); end; Reg.CloseKey; end end end end finally Reg.CloseKey; Reg.Free end; Success := False; ActivePIDLs := ChildPIDLs; if not Assigned(ParentPIDL) and Assigned(ChildPIDLs) then begin FromDesktop := True; SHGetDesktopFolder(FActiveFolder); SHGetSpecialFolderLocation(0, CSIDL_DESKTOP, DesktopPIDL); Success := CDefFolderMenu_Create2_MP(DesktopPIDL, Owner.Handle, Length(ChildPIDLs), PItemIDList(ChildPIDLs[0]), Self, Stub, Length(Keys), PHKey(@Keys[0]), ContextMenu) = S_OK; end else begin FromDesktop := False; SHGetDesktopFolder(Desktop); if PIDLMgr.IsDesktopFolder(ParentPIDL) then FActiveFolder := Desktop else Desktop.BindToObject(ParentPIDL, nil, IShellFolder, Pointer( FActiveFolder)); if Assigned(ActiveFolder) then begin if Assigned(ParentPIDL) and Assigned(ChildPIDLs) then Success := CDefFolderMenu_Create2_MP(ParentPIDL, Owner.Handle, Length(ChildPIDLs), PItemIDList(ChildPIDLs[0]), Self, Stub, Length(Keys), PHKey(@Keys[0]), ContextMenu) = S_OK else begin // Must be a background menu call ChildrenPIDLs := nil; if Assigned(ParentPIDL) and not Assigned(ChildPIDLs) then Success := CDefFolderMenu_Create2_MP(ParentPIDL, Owner.Handle, 0, ChildrenPIDLs, Self, Stub, Length(Keys), PHKey(@Keys[0]), ContextMenu) = S_OK end end end; if Success then begin CurrentContextMenu := ContextMenu; CurrentContextMenu2 := nil; // not sure it is available yet if Assigned(ContextMenu) then begin if ContextMenu.QueryInterface(IContextMenu3, Pointer(ContextMenu3)) = E_NOINTERFACE then begin if ContextMenu.QueryInterface(IID_IContextMenu2, Pointer(ContextMenu2)) <> E_NOINTERFACE then CurrentContextMenu2 := ContextMenu2; end else CurrentContextMenu2 := ContextMenu3; if Assigned(ContextMenu3) then ContextMenu3.QueryContextMenu(Menu, 0, 1, $7FFF, Flags) else if Assigned(ContextMenu2) then ContextMenu2.QueryContextMenu(Menu, 0, 1, $7FFF, Flags) else if Assigned(ContextMenu) then ContextMenu.QueryContextMenu(Menu, 0, 1, $7FFF, Flags); // May just be executing a verb AllowShow := Verb = ''; if AllowShow then MenuCmd := Cardinal( TrackPopupMenuEx( Menu, TPM_LEFTALIGN or TPM_RETURNCMD or TPM_RIGHTBUTTON, x, y, Owner.Handle, nil)) else MenuCmd := 0; if (MenuCmd <> 0) or (Verb <> '') then begin if (MenuCmd <> 0) then begin if IsUnicode then begin SetLength(VerbW, MaxVerbLen); GenericVerb := @VerbW[1]; Flags := GCS_VERBW end else begin SetLength(VerbA, MaxVerbLen); GenericVerb := @VerbA[1]; Flags := GCS_VERBA end; if Assigned(ContextMenu3) then Result := Succeeded(ContextMenu3.GetCommandString(MenuCmd-1, Flags, nil, GenericVerb, MaxVerbLen)) else if Assigned(ContextMenu2) then Result := Succeeded(ContextMenu2.GetCommandString(MenuCmd-1, Flags, nil, GenericVerb, MaxVerbLen)) else if Assigned(ContextMenu) then Result := Succeeded(ContextMenu.GetCommandString(MenuCmd-1, Flags, nil, GenericVerb, MaxVerbLen)); if IsUnicode then SetLength(VerbW, lstrlenW(PWideChar( VerbW))) else begin SetLength(VerbA, StrLen(PChar( VerbA))); VerbW := VerbA end; end else begin VerbW := Verb; VerbA := Verb; Result := True; end; if not Result then VerbW := STR_UNKNOWNCOMMAN; Handled := False; if not Handled then begin FillChar(InvokeInfo, SizeOf(InvokeInfo), #0); with InvokeInfo do begin if MenuCmd > 0 then begin { For some reason the lpVerbW won't work } lpVerb := MakeIntResourceA(MenuCmd-1); if IsUnicode then begin fMask := CMIC_MASK_UNICODE; lpVerbW := MakeIntResourceW(MenuCmd-1); end; end else begin if IsUnicode then begin fMask := CMIC_MASK_UNICODE; lpVerbW := PWideChar( VerbW); lpVerb := PChar( VerbA) end else lpVerb := PChar( VerbA) end; // Win95 get confused if size = TCMInvokeCommandInfoEx if IsUnicode then cbSize := SizeOf(TCMInvokeCommandInfoEx) else cbSize := SizeOf(TCMInvokeCommandInfo); hWnd := Owner.Handle; nShow := SW_SHOWNORMAL; end; if Assigned(ContextMenu3) then Result := Succeeded(ContextMenu3.InvokeCommand(InvokeInfo)) else if Assigned(ContextMenu2) then Result := Succeeded(ContextMenu2.InvokeCommand(InvokeInfo)) else if Assigned(ContextMenu) then Result := Succeeded(ContextMenu.InvokeCommand(InvokeInfo)); end end end end finally PIDLMgr.FreePIDL(DesktopPIDL); CurrentContextMenu := nil; CurrentContextMenu2 := nil; ContextMenu := nil; ContextMenu2 := nil; ContextMenu3 := nil; FActiveFolder := nil; Desktop := nil; // Special handling because this is a non reference counted Component if Assigned(UIObjectOfDataObject) then UIObjectOfDataObject._Release; UIObjectOfDataObject := nil; if Assigned(UIObjectOfDropTarget) then UIObjectOfDropTarget._Release; UIObjectOfDropTarget := nil; { Don't access any properties or field of the object. If the verb is } { 'delete' the component using this class could have freed the instance } { of the object through a ShellNotifyRegister or some other way. } DestroyMenu(Menu); for i := 0 to Length(Keys) - 1 do RegCloseKey(Keys[i]); Keys := nil; end; finally Owner.WindowProc := FOldWndProcForContextMenu; FOldWndProcForContextMenu := nil; end; end end; finally SetErrorMode(OldMode); end except end end end; procedure TCommonShellContextMenu.AddMenuKey(Key: WideString); begin KeyStrings.Add(Key) end; {$IFDEF TNTSUPPORT} procedure TCommonShellContextMenu.AddMenuKeys(Keys: TTntStringList); begin KeyStrings.Assign(Keys) end; {$ELSE} procedure TCommonShellContextMenu.AddMenuKeys(Keys: TStringList); begin KeyStrings.Assign(Keys) end; {$ENDIF} procedure TCommonShellContextMenu.ClearKeys; begin KeyStrings.Clear end; procedure TCommonShellContextMenu.ClearMenuMap; begin MenuMap.Clear end; procedure TCommonShellContextMenu.DoCopy(ShellFolder: IShellFolder; DataObject: IDataObject; var DoDefault: Boolean); begin if Assigned(OnShellMenuCopy) then OnShellMenuCopy(Self, ShellFolder, DataObject, DoDefault) end; procedure TCommonShellContextMenu.DoCreateShortCut(ShellFolder: IShellFolder; DataObject: IDataObject; var DoDefault: Boolean); begin if Assigned(OnShellMenuCreateShortCut) then OnShellMenuCreateShortCut(Self, ShellFolder, DataObject, DoDefault) end; procedure TCommonShellContextMenu.DoCut(ShellFolder: IShellFolder; DataObject: IDataObject; var DoDefault: Boolean); begin if Assigned(OnShellMenuCut) then OnShellMenuCut(Self, ShellFolder, DataObject, DoDefault) end; procedure TCommonShellContextMenu.DoDelete(ShellFolder: IShellFolder; DataObject: IDataObject; var DoDefault: Boolean); begin if Assigned(OnShellMenuDelete) then OnShellMenuDelete(Self, ShellFolder, DataObject, DoDefault) end; procedure TCommonShellContextMenu.DoHide; begin if Assigned(OnHide) then OnHide(Self); end; {$IFDEF TNTSUPPORT} procedure TCommonShellContextMenu.DoInvokeCommand(MenuItem: TTntMenuItem; InvokeInfo: PCMInvokeCommandInfo); var Handled: Boolean; begin Handled := False; if Assigned(OnInvokeCommand) then OnInvokeCommand(Self, MenuItem, InvokeInfo, Handled); if not Handled then MenuItem.Click; end; {$ELSE} procedure TCommonShellContextMenu.DoInvokeCommand(MenuItem: TMenuItem; InvokeInfo: PCMInvokeCommandInfo); var Handled: Boolean; begin Handled := False; if Assigned(OnInvokeCommand) then OnInvokeCommand(Self, MenuItem, InvokeInfo, Handled); if not Handled then MenuItem.Click; end; {$ENDIF} procedure TCommonShellContextMenu.DoMenuMerge(Menu: HMENU; IndexMenu: UINT; var CmdFirst: UINT; CmdLast: UINT; Flags: TShellContextMenuFlags); begin if Assigned(OnMenuMerge) then OnMenuMerge(Self, Menu, IndexMenu, CmdFirst, CmdLast, Flags); end; procedure TCommonShellContextMenu.DoMenuMergeBottom(Menu: HMENU; IndexMenu: UINT; var CmdFirst: UINT; CmdLast: UINT; Flags: TShellContextMenuFlags); begin if Assigned(OnMenuMergeBottom) then OnMenuMergeBottom(Self, Menu, IndexMenu, CmdFirst, CmdLast, Flags); end; procedure TCommonShellContextMenu.DoMenuMergeTop(Menu: HMENU; IndexMenu: UINT; var CmdFirst: UINT; CmdLast: UINT; Flags: TShellContextMenuFlags); begin if Assigned(OnMenuMergeTop) then OnMenuMergeTop(Self, Menu, IndexMenu, CmdFirst, CmdLast, Flags); end; procedure TCommonShellContextMenu.DoNewFolder(ShellFolder: IShellFolder; DataObject: IDataObject; var DoDefault: Boolean); begin if Assigned(OnShellMenuNewFolder) then OnShellMenuNewFolder(Self, ShellFolder, DataObject, DoDefault) end; procedure TCommonShellContextMenu.DoPaste(ShellFolder: IShellFolder; DataObject: IDataObject; var DoDefault: Boolean); begin if Assigned(OnShellMenuPaste) then OnShellMenuPaste(Self, ShellFolder, DataObject, DoDefault) end; procedure TCommonShellContextMenu.DoPasteLink(ShellFolder: IShellFolder; DataObject: IDataObject; var DoDefault: Boolean); begin if Assigned(OnShellMenuPasteLink) then OnShellMenuPasteLink(Self, ShellFolder, DataObject, DoDefault) end; procedure TCommonShellContextMenu.DoPasteShortCut(ShellFolder: IShellFolder; DataObject: IDataObject; var DoDefault: Boolean); begin if Assigned(OnShellMenuPasteShortCut) then OnShellMenuPasteShortCut(Self, ShellFolder, DataObject, DoDefault) end; procedure TCommonShellContextMenu.DoProperties(ShellFolder: IShellFolder; DataObject: IDataObject; var DoDefault: Boolean); begin if Assigned(OnShellMenuProperites) then OnShellMenuProperites(Self, ShellFolder, DataObject, DoDefault) end; procedure TCommonShellContextMenu.DoShow; begin if Assigned(OnShow) then OnShow(Self); end; procedure TCommonShellContextMenu.HandleContextMenuMsg(Msg, wParam, lParam: Longint; var Result: LRESULT); { This is called when the ContextMenu calls back to its owner window to ask } { questions to implement the addition of icons to the menu. The messages sent } { to the owner window are: WM_INITMENUPOPUP, WM_DRAWITEM, or WM_MEASUREITEM. } { Which must be passed on to the ContextMenu2 interface to display items with } { icons. } var ContextMenu3: IContextMenu3; begin if Assigned(CurrentContextMenu2) then if CurrentContextMenu2.QueryInterface(IContextMenu3, ContextMenu3) <> E_NOINTERFACE then Result := ContextMenu3.HandleMenuMsg2(Msg, wParam, lParam, Result) else Result := CurrentContextMenu2.HandleMenuMsg(Msg, wParam, lParam); end; procedure TCommonShellContextMenu.LoadMultiFolderPIDLArray(Namespaces: TNamespaceArray; var PIDLs: TAbsolutePIDLArray); var i: Integer; begin CopyValidated := True; CutValidated := True; SetLength(PIDLs, Length(Namespaces)); for i := 0 to Length(Namespaces) - 1 do begin PIDLs[i] := Namespaces[i].AbsolutePIDL; if Namespaces[i].Folder and not Namespaces[i].Browsable then Include(FExtensions, cmeDirectory); if CopyValidated then CopyValidated := Namespaces[i].CanCopy; if CutValidated then CutValidated := Namespaces[i].CanMove; if Namespaces[i].Folder and not Namespaces[i].Directory then Include(FExtensions, cmeFolder); end; end; procedure TCommonShellContextMenu.WindowProcForContextMenu(var Message: TMessage); begin FOldWndProcForContextMenu(Message); // Call the OldWindProc of the ContextMenu owner case Message.Msg of WM_DRAWITEM, WM_INITMENUPOPUP, WM_MEASUREITEM, WM_MENUCHAR: HandleContextMenuMsg(Message.Msg, Message.WParam, Message.LParam, Message.Result); end; end; function TCommonShellContextMenu._AddRef: Integer; begin Result := -1 end; function TCommonShellContextMenu._Release: Integer; begin Result := -1 end; function TCommonShellContextMenu.QueryInterface(const IID: TGUID; out Obj): HResult; begin Result := inherited QueryInterface(IID, Obj); {$IFDEF GXDEBUG_VIRTUALCONTEXTMENU} SendDebug('QueryInterface - ' + GUIDToInterfaceStr(IID)); {$ENDIF} end; {$IFDEF TNTSUPPORT} function TCommonShellContextMenu.MergeMenuIntoContextMenu(Menu: TTntPopupMenu; ContextMenu: HMenu; Index: Integer; idStart: UINT): Integer; // // Returns the ItemID of the last item it added to the ContextMenu // function RunMenu(MenuItem: TTntMenuItem; hPopupMenu: hMenu; MenuID: UINT): Integer; var i: Integer; SubMenu: hMenu; Map: PMenuItemLink; NewIndex: Integer; begin Result := MenuID; if MenuItem.Count > 0 then begin // Item has sub-items and won't take a MenuID SubMenu := CreatePopupMenu; NewIndex := AddContextMenuItem(hPopupMenu, MenuItem.Caption, Index, Result, SubMenu); for i := MenuItem.Count - 1 downto 0 do Result := RunMenu(MenuItem.Items[i] as TTntMenuItem, SubMenu, Result); end else NewIndex := AddContextMenuItem(hPopupMenu, MenuItem.Caption, Index, Result, 0); if NewIndex <> $FFFF then begin Map := MenuMap.Add; Map.MenuID := Result; Map.Item := MenuItem; Inc(Result) end; end; var i: Integer; begin Result := idStart; for i := Menu.Items.Count - 1 downto 0 do Result := RunMenu(Menu.Items[i] as TTntMenuItem, ContextMenu, Result) end; {$ELSE} function TCommonShellContextMenu.MergeMenuIntoContextMenu(Menu: TPopupMenu; ContextMenu: HMenu; Index: Integer; idStart: UINT): Integer; // // Returns the ItemID of the last item it added to the ContextMenu // function RunMenu(MenuItem: TMenuItem; hPopupMenu: hMenu; MenuID: UINT): Integer; var i: Integer; SubMenu: hMenu; Map: PMenuItemLink; NewIndex: Integer; begin Result := MenuID; if MenuItem.Count > 0 then begin // Item has sub-items and won't take a MenuID SubMenu := CreatePopupMenu; NewIndex := AddContextMenuItem(hPopupMenu, MenuItem.Caption, Index, Result, SubMenu, MenuItem.Enabled, MenuItem.Checked, MenuItem.Default); for i := MenuItem.Count - 1 downto 0 do Result := RunMenu(MenuItem.Items[i], SubMenu, Result); end else NewIndex := AddContextMenuItem(hPopupMenu, MenuItem.Caption, Index, Result, 0, MenuItem.Enabled, MenuItem.Checked, MenuItem.Default); if NewIndex <> $FFFF then begin Map := MenuMap.Add; Map.MenuID := Result; Map.Item := MenuItem; Inc(Result) end; end; var i: Integer; begin Result := idStart; for i := Menu.Items.Count - 1 downto 0 do Result := RunMenu(Menu.Items[i], ContextMenu, Result) end; {$ENDIF} { TCommonShellMultiParentContextMenu} function TCommonShellMultiParentContextMenu.ExecuteContextMenuVerb( Owner: TWinControl; Namespaces: TNamespaceArray; Verb: string): Boolean; var PIDLs: TAbsolutePIDLArray; begin PIDLs := nil; LocalFocused := nil; LocalNamespaces := Namespaces; RenameMenuItem := True; LoadRegistryKeyStrings(nil); LoadMultiFolderPIDLArray(Namespaces, PIDLs); Result := InternalShowContextMenu(Owner, nil, PIDLs, Verb, nil); end; function TCommonShellMultiParentContextMenu.ShowContextMenu(Owner: TWinControl; Focused: TNamespace; Namespaces: TNamespaceArray; Position: PPoint = nil): Boolean; var PIDLs: TAbsolutePIDLArray; begin PIDLs := nil; LocalFocused := Focused; LocalNamespaces := Namespaces; RenameMenuItem := True; LoadRegistryKeyStrings(Focused); LoadMultiFolderPIDLArray(Namespaces, PIDLs); Result := InternalShowContextMenu(Owner, nil, PIDLs, '', Position); end; procedure TCommonShellMultiParentContextMenu.LoadRegistryKeyStrings(Focused: TNamespace); begin KeyStrings.Clear; Extensions := [cmeShellDefault, cmeAsterik, cmeAllFilesystemObjects, cmeFileSystemAssociations]; // Only add the menu handlers for the focused item class if Assigned(Focused) then begin if Focused.Folder then Extensions := [cmeShellDefault, {cmeDirectory,} cmeFolder] else AddMenuKey(WideExtractFileExt(Focused.NameForParsing)); end end; { TCommonShellBackgroundContextMenu } constructor TCommonShellBackgroundContextMenu.Create(AOwner: TComponent); begin inherited Create(AOwner); FInitialItemList := TCommonPIDLList.Create; FFinalItemList := TCommonPIDLList.Create; FRenameMenuItem := False; FPasteMenuItem := False; FShowPasteItem := True; FShowPasteShortCutItem := True; FShowPropertiesItem := True; FAutoDetectNewItem := True; {$IFDEF TNTSUPPORT} PopupMenuProperties := TTntPopupMenu.Create(Self); PopupMenuPasteShortCut := TTntPopupMenu.Create(Self); PopupMenuPaste := TTntPopupMenu.Create(Self); Paste := TTntMenuItem.Create(PopupMenuPaste); PasteShortCut := TTntMenuItem.Create(PopupMenuPasteShortCut); Properties := TTntMenuItem.Create(PopupMenuProperties); {$ELSE} PopupMenuProperties := TPopupMenu.Create(Self); PopupMenuPasteShortCut := TPopupMenu.Create(Self); PopupMenuPaste := TPopupMenu.Create(Self); Paste := TMenuItem.Create(PopupMenuPaste); PasteShortCut := TMenuItem.Create(PopupMenuPasteShortCut); Properties := TMenuItem.Create(PopupMenuProperties); {$ENDIF} Paste.Caption := STR_PASTELINK; PasteShortCut.Caption := STR_PASTE; Properties.Caption := STR_PROPERTIES; Paste.OnClick := ClickPaste; PasteShortCut.OnClick := ClickPasteShortCut; Properties.OnClick := ClickProperties; PopupMenuProperties.Items.Add(Properties); PopupMenuPasteShortCut.Items.Add(PasteShortCut); PopupMenuPaste.Items.Add(Paste); end; destructor TCommonShellBackgroundContextMenu.Destroy; begin FreeAndNil(FInitialItemList); FreeAndNil(FFinalItemList); inherited Destroy; end; function TCommonShellBackgroundContextMenu.EnumCallback(MessageWnd: HWnd; APIDL: PItemIDList; AParent: TNamespace; Data: Pointer; var Terminate: Boolean): Boolean; begin // copy the relative PIDLs TCommonPIDLList( Data).Add(APIDL); Result := True; end; function TCommonShellBackgroundContextMenu.ShowContextMenu( Owner: TWinControl; Root: TNamespace; Position: PPoint): Boolean; begin Result := False; LocalFocused := Root; LocalNamespaces := nil; if Assigned(Root) then begin if Root.Folder then begin RenameMenuItem := True; LoadRegistryKeyStrings(Root); Result := InternalShowContextMenu(Owner, Root.AbsolutePIDL, nil, '', Position); end end end; procedure TCommonShellBackgroundContextMenu.ClickPaste(Sender: TObject); var NSA: TNamespaceArray; begin if Assigned(LocalFocused) then begin SetLength(NSA, 1); NSA[0] := LocalFocused; LocalFocused.Paste(NSA, False) end end; procedure TCommonShellBackgroundContextMenu.ClickPasteShortCut(Sender: TObject); var NSA: TNamespaceArray; begin if Assigned(LocalFocused) then begin SetLength(NSA, 1); NSA[0] := LocalFocused; LocalFocused.Paste(NSA, True) end end; procedure TCommonShellBackgroundContextMenu.ClickProperties(Sender: TObject); begin if Assigned(LocalFocused) then LocalFocused.ShowPropertySheet end; procedure TCommonShellBackgroundContextMenu.DoHide; var i: Integer; Found: Boolean; NS: TNamespace; begin inherited DoHide; if AutoDetectNewItem and Assigned(LocalFocused) then begin LocalFocused.EnumerateFolder(0, True, True, False, EnumCallback, FinalItemList); if (InitialItemList.Count + 1) = FinalItemList.Count then begin // One item was added, time to find it. PIDLListQuickSort(InitialItemList, LocalFocused.ShellFolder, 0, InitialItemList.Count - 1); PIDLListQuickSort(FinalItemList, LocalFocused.ShellFolder, 0, FinalItemList.Count - 1); Found := False; i := 0; while not Found and (i < FinalItemList.Count) do begin Found := LocalFocused.ShellFolder.CompareIDs(0, InitialItemList[i], FinalItemList[i]) <> 0; if Found then begin NS := TNamespace.Create(FinalItemList[i], LocalFocused); NS.FreePIDLOnDestroy := False; DoNewItem(NS); NS.Free end; Inc(i) end end end; FinalItemList.Clear; InitialItemList.Clear; end; procedure TCommonShellBackgroundContextMenu.DoMenuMerge(Menu: HMENU; IndexMenu: UINT; var CmdFirst: UINT; CmdLast: UINT; Flags: TShellContextMenuFlags); begin inherited DoMenuMerge(Menu, IndexMenu, CmdFirst, CmdLast, Flags); end; procedure TCommonShellBackgroundContextMenu.DoMenuMergeBottom(Menu: HMENU; IndexMenu: UINT; var CmdFirst: UINT; CmdLast: UINT; Flags: TShellContextMenuFlags); begin if ShowPropertiesItem then begin if Assigned(LocalFocused) then Properties.Enabled := LocalFocused.HasPropSheet else Properties.Enabled := False; CmdFirst := MergeMenuIntoContextMenu(PopupMenuProperties, Menu, IndexMenu, CmdFirst); AddContextMenuItem(Menu, '-', IndexMenu); end; inherited DoMenuMergeBottom(Menu, IndexMenu, CmdFirst, CmdLast, Flags); end; procedure TCommonShellBackgroundContextMenu.DoMenuMergeTop(Menu: HMENU; IndexMenu: UINT; var CmdFirst: UINT; CmdLast: UINT; Flags: TShellContextMenuFlags); begin Paste.Enabled := ClipboardContainsShellFormats; PasteShortCut.Enabled := ClipboardContainsShellFormats; if ShowPasteItem or ShowPasteShortCutItem then AddContextMenuItem(Menu, '-', IndexMenu); if ShowPasteItem then CmdFirst := MergeMenuIntoContextMenu(PopupMenuPaste, Menu, IndexMenu, CmdFirst); if ShowPasteShortCutItem then CmdFirst := MergeMenuIntoContextMenu(PopupMenuPasteShortCut, Menu, IndexMenu, CmdFirst); if ShowPasteItem or ShowPasteShortCutItem then AddContextMenuItem(Menu, '-', IndexMenu); inherited DoMenuMergeTop(Menu, IndexMenu, CmdFirst, CmdLast, Flags); end; procedure TCommonShellBackgroundContextMenu.DoNewItem(NS: TNamespace); begin if Assigned(OnNewItem) then OnNewItem(Self, NS) end; procedure TCommonShellBackgroundContextMenu.DoShow; begin inherited DoShow; if AutoDetectNewItem and Assigned(LocalFocused) then begin InitialItemList.Clear; LocalFocused.EnumerateFolder(0, True, True, False, EnumCallback, InitialItemList) end end; procedure TCommonShellBackgroundContextMenu.LoadRegistryKeyStrings(Focused: TNamespace); begin CopyValidated := False; CutValidated := False; KeyStrings.Clear; PasteMenuItem := True; Extensions := [cmeShellDefault, cmeDirBackground]; end; { TMenuItemMap } function TMenuItemMap.Add: PMenuItemLink; begin New(Result); if Assigned(Result) then inherited Insert(Count, Result) end; function TMenuItemMap.First: PMenuItemLink; begin Result := PMenuItemLink( inherited First) end; function TMenuItemMap.Get(Index: Integer): PMenuItemLink; begin Result := PMenuItemLink( inherited Get(Index)) end; function TMenuItemMap.IndexOf(Item: PMenuItemLink): Integer; begin Result := inherited IndexOf(Item) end; function TMenuItemMap.Last: PMenuItemLink; begin Result := PMenuItemLink( inherited Last) end; function TMenuItemMap.Remove(Item: PMenuItemLink): Integer; begin Result := inherited Remove(Item) end; procedure TMenuItemMap.Clear; var i: Integer; begin try for i := 0 to Count - 1 do Dispose( Items[i]); finally SetCount(0); SetCapacity(0); end; end; function TMenuItemMap.Insert(Index: Integer): PMenuItemLink; begin New(Result); if Assigned(Result) then inherited Insert(Index, Result) end; procedure TMenuItemMap.Put(Index: Integer; Item: PMenuItemLink); begin inherited Put(Index, Item) end; initialization CoInitialize(nil); // if IsWinNT4 then FileIconInit(True); // This MUST be before the Namespaces are created or it won't work because the IconCache may have an icon in from the namespace if not LoadShell32Functions then Halt(0); PIDLMgr := TCommonPIDLManager.Create; DesktopFolder := CreateSpecialNamespace(CSIDL_DESKTOP); RecycleBinFolder := CreateSpecialNamespace(CSIDL_BITBUCKET); PhysicalDesktopFolder := CreateSpecialNamespace(CSIDL_DESKTOPDIRECTORY); DrivesFolder := CreateSpecialNamespace(CSIDL_DRIVES); PrinterFolder := CreateSpecialNamespace(CSIDL_PRINTERS); HistoryFolder := CreateSpecialNamespace(CSIDL_HISTORY); ControlPanelFolder := CreateSpecialNamespace(CSIDL_CONTROLS); NetworkNeighborHoodFolder := CreateSpecialNamespace(CSIDL_NETWORK); TemplatesFolder := CreateSpecialNamespace(CSIDL_TEMPLATES); MyDocumentsFolder := CreateSpecialNamespace(CSIDL_PERSONAL); FavoritesFolder := CreateSpecialNamespace(CSIDL_FAVORITES); UserDocumentsFolder := CreateSpecialNamespace(CSIDL_APPDATA); ProgramFilesFolder := CreateSpecialNamespace(CSIDL_PROGRAMS); finalization FreeAndNil(DesktopFolder); FreeAndNil(RecycleBinFolder); FreeAndNil(PhysicalDesktopFolder); FreeAndNil(DrivesFolder); FreeAndNil(HistoryFolder); FreeAndNil(PrinterFolder); FreeAndNil(ControlPanelFolder); FreeAndNil(NetworkNeighborHoodFolder); FreeAndNil(TemplatesFolder); FreeAndNil(MyDocumentsFolder); FreeAndNil(FavoritesFolder); FreeAndNil(UserDocumentsFolder); FreeAndNil(ProgramFilesFolder); FreeAndNil(PIDLMgr); CoUninitialize; end.