bsskinshellctrls.pas

一套非常好用的delphi控件,方便程序员工作

{*******************************************************************}
{                                                                   }
{       Almediadev Visual Component Library                         }
{       BusinessSkinForm                                            }
{       Version 4.27                                                }
{                                                                   }
{       Copyright (c) 2000-2006 Almediadev                          }
{       ALL RIGHTS RESERVED                                         }
{                                                                   }
{       Home:  http://www.almdev.com                                }
{       Support: [e-mail]                                 }
{                                                                   }
{*******************************************************************}

unit bsSkinShellCtrls;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, CommCtrl, ShlObj, ActiveX, StdCtrls, ImgList, bsSkinCtrls,
  BusinessSkinForm, bsSkinData, bsSkinBoxCtrls, bsFileCtrl, ExtCtrls,
  Menus, bsSkinMenus;

type
  TRoot = type string;

  TRootFolder = (rfDesktop, rfMyComputer, rfNetwork, rfRecycleBin, rfAppData,
    rfCommonDesktopDirectory, rfCommonPrograms, rfCommonStartMenu, rfCommonStartup,
    rfControlPanel, rfDesktopDirectory, rfFavorites, rfFonts, rfInternet, rfPersonal,
    rfPrinters, rfPrintHood, rfPrograms, rfRecent, rfSendTo, rfStartMenu, rfStartup,
    rfTemplates);

  TbsShellFolderCapability = (fcCanCopy, fcCanDelete, fcCanLink, fcCanMove, fcCanRename,
                   fcDropTarget, fcHasPropSheet);
  TbsShellFolderCapabilities = set of TbsShellFolderCapability;

  TbsShellFolderProperty = (fpCut, fpIsLink, fpReadOnly, fpShared, fpFileSystem,
    fpFileSystemAncestor, fpRemovable, fpValidate);

  TbsShellFolderProperties = set of TbsShellFolderProperty;
                                                             
  TShellObjectType = (otFolders, otNonFolders, otHidden);
  TShellObjectTypes = set of TShellObjectType;

  EInvalidPath = class(Exception);

  IShellCommandVerb = interface
    ['{7D2A7245-2376-4D33-8008-A130935A2E8B}']
    procedure ExecuteCommand(Verb: string; var Handled: boolean);
    procedure CommandCompleted(Verb: string; Succeeded: boolean);
  end;

{$IFDEF VER130}
  {$DEFINE BS56}
  {$ENDIF}
  {$IFDEF VER140}
    {$IFNDEF BCB}
      {$DEFINE BS56}
    {$ENDIF}
  {$ENDIF}

  {$IFDEF BS56}
  IInterface = interface
    ['{00000000-0000-0000-C000-000000000046}']
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  end;

  {$HPPEMIT 'typedef System::DelphiInterface<IShellFolder2> _di_IShellFolder2;'}
  {$EXTERNALSYM IID_IShellFolder2}
   const
     SID_IShellDetails      = '{000214EC-0000-0000-C000-000000000046}';
     SID_IEnumExtraSearch   = '{0E700BE1-9DB6-11D1-A1CE-00C04FD75D13}';
     IID_IShellFolder2: TGUID = (
       D1:$93F2F68C; D2:$1D1B; D3:$11D3; D4:($A3,$0E,$00,$C0,$4F,$79,$AB,$D1));
     SID_IShellFolder2      = '{B82C5AA8-A41B-11D2-BE32-00C04FB93661}';
     SHCOLSTATE_TYPE_STR     = $00000001;
     SHCOLSTATE_TYPE_INT     = $00000002;
     SHCOLSTATE_TYPE_DATE    = $00000003;
     SHCOLSTATE_TYPEMASK     = $0000000F;
     SHCOLSTATE_ONBYDEFAULT  = $00000010;
     SHCOLSTATE_SLOW         = $00000020;
     SHCOLSTATE_EXTENDED     = $00000040;
     SHCOLSTATE_SECONDARYUI  = $00000080;   
     SHCOLSTATE_HIDDEN       = $00000100;
     {$EXTERNALSYM IID_IEnumExtraSearch}
     IID_IEnumExtraSearch: TGUID = (
       D1:$E700BE1; D2: $9DB6; D3:$11D1; D4:($A1,$CE,$00,$C0,$4F,$D7,$5D,$13));
      {$EXTERNALSYM IID_IShellDetails}
     IID_IShellDetails: TGUID = (
      D1:$000214EC; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));
   type

   { IShellDetails is supported on Win9x and NT4; for >= NT5 use IShellFolder2 }
   PShellDetails = ^TShellDetails;
   {$EXTERNALSYM _SHELLDETAILS}
    _SHELLDETAILS = record
     fmt,
     cxChar: Integer;
     str: STRRET;
   end;

   TShellDetails = _SHELLDETAILS;
   SHELLDETAILS = _SHELLDETAILS;
   IShellDetails = interface(IUnknown)
     [SID_IShellDetails]
     function GetDetailsOf(pidl: PItemIDList; iColumn: UINT;
       var pDetails: TShellDetails): HResult; stdcall;
     function ColumnClick(iColumn: UINT): HResult; stdcall;
   end;

   {$EXTERNALSYM PShColumnID}
   PShColumnID = ^TShColumnID;
   {$EXTERNALSYM SHCOLUMNID}
   SHCOLUMNID = record
     fmtid: TGUID;
     pid: DWORD;
   end;
   {$EXTERNALSYM TShColumnID}
   TShColumnID = SHCOLUMNID;


   {$EXTERNALSYM PExtraSearch}
   PExtraSearch = ^TExtraSearch;
   {$EXTERNALSYM tagExtraSearch}
   tagExtraSearch = record
    guidSearch: TGUID;
    wszFriendlyName,
    wszMenuText: array[0..79] of WideChar;
    wszHelpText: array[0..MAX_PATH] of WideChar;
    wszUrl: array[0..2047] of WideChar;
    wszIcon,
    wszGreyIcon,
    wszClrIcon: array[0..MAX_PATH+10] of WideChar;
   end;
  {$EXTERNALSYM TExtraSearch}
  TExtraSearch = tagExtraSearch;

   {$EXTERNALSYM IEnumExtraSearch}
    IEnumExtraSearch = interface(IUnknown)
    [SID_IEnumExtraSearch]
    function Next(celt: ULONG; out rgelt: PExtraSearch;
      out pceltFetched: ULONG): HResult; stdcall;
    function Skip(celt: ULONG): HResult; stdcall;
    function Reset: HResult; stdcall;
    function Clone(out ppEnum: IEnumExtraSearch): HResult; stdcall;
  end;

    {$EXTERNALSYM IShellFolder2}
    IShellFolder2 = interface(IShellFolder)
    [SID_IShellFolder2]
    function GetDefaultSearchGUID(out pguid: TGUID): HResult; stdcall;
    function EnumSearches(out ppEnum: IEnumExtraSearch): HResult; stdcall;
    function GetDefaultColumn(dwRes: DWORD; var pSort: ULONG;
      var pDisplay: ULONG): HResult; stdcall;
    function GetDefaultColumnState(iColumn: UINT; var pcsFlags: DWORD): HResult; stdcall;
    function GetDetailsEx(pidl: PItemIDList; const pscid: SHCOLUMNID;
      pv: POleVariant): HResult; stdcall;
    function GetDetailsOf(pidl: PItemIDList; iColumn: UINT;
      var psd: TShellDetails): HResult; stdcall;
    function MapNameToSCID(pwszName: LPCWSTR; var pscid: TShColumnID): HResult; stdcall;
  end;
  {$ENDIF}
  
type
  TbsShellFolder = class
  private
    FPIDL,
    FFullPIDL: PItemIDList;
    FParent: TbsShellFolder;
    FIShellFolder: IShellFolder;
    FIShellFolder2: IShellFolder2;
    FIShellDetails: IShellDetails;
    FDetailInterface: IInterface;
    FLevel: Integer;
    FViewHandle: THandle;
    FDetails: TStrings;
    function GetDetailInterface: IInterface;
    function GetShellDetails: IShellDetails;
    function GetShellFolder2: IShellFolder2;
    function GetDetails(Index: integer): string;
    procedure SetDetails(Index: integer; const Value: string);
    procedure LoadColumnDetails(RootFolder: TbsShellFolder; Handle: THandle; ColumnCount: integer);
  public
    constructor Create(AParent: TbsShellFolder; ID: PItemIDList; SF: IShellFolder); virtual;
    destructor Destroy; override;
    function Capabilities: TbsShellFolderCapabilities;
    function DisplayName: string;
    function ExecuteDefault: Integer;
    function ImageIndex(LargeIcon: Boolean): Integer;
    function IsFolder: Boolean;
    function ParentShellFolder: IShellFolder;
    function PathName: string;
    function FullObjectName: String;
    function Properties: TbsShellFolderProperties;
    function Rename(const NewName: WideString): boolean;
    function SubFolders: Boolean;
    property AbsoluteID: PItemIDLIst read FFullPIDL;
    property Details[Index: integer] : string read GetDetails write SetDetails;
    property Level: Integer read FLevel;
    property Parent: TbsShellFolder read FParent;
    property RelativeID: PItemIDList read FPIDL;
    property ShellFolder: IShellFolder read FIShellFolder;
    property ShellFolder2: IShellFolder2 read GetShellFolder2;
    property ShellDetails: IShellDetails read GetShellDetails;
    property ViewHandle: THandle read FViewHandle write FViewHandle;
  end;

  TNotifyFilter = (nfFileNameChange, nfDirNameChange, nfAttributeChange,
    nfSizeChange, nfWriteChange, nfSecurityChange);
  TNotifyFilters = set of TNotifyFilter;

  TbsShellChangeThread = class(TThread)
  private
    FMutex,
    FWaitHandle: Integer;
    FChangeEvent: TThreadMethod;
    FDirectory: string;
    FWatchSubTree: Boolean;
    FWaitChanged : Boolean;
    FNotifyOptionFlags: DWORD;
  protected
    procedure Execute; override;
  public
    constructor Create(ChangeEvent: TThreadMethod); virtual;
    destructor Destroy; override;
    procedure SetDirectoryOptions( Directory : String; WatchSubTree : Boolean;
      NotifyOptionFlags : DWORD);
    property ChangeEvent : TThreadMethod read FChangeEvent write FChangeEvent;
  end;

  TbsCustomShellChangeNotifier = class(TComponent)
  private
    FFilters: TNotifyFilters;
    FWatchSubTree: Boolean;
    FRoot : TRoot;
    FThread: TbsShellChangeThread;
    FOnChange: TThreadMethod;
    procedure SetRoot(const Value: TRoot);
    procedure SetWatchSubTree(const Value: Boolean);
    procedure SetFilters(const Value: TNotifyFilters);
    procedure SetOnChange(const Value: TThreadMethod);
  protected
    procedure Change;
    procedure Start;
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    property NotifyFilters: TNotifyFilters read FFilters write SetFilters;
    property Root: TRoot read FRoot write SetRoot;
    property WatchSubTree: Boolean read FWatchSubTree write SetWatchSubTree;
    property OnChange: TThreadMethod read FOnChange write SetOnChange;
  end;

  TbsShellChangeNotifier = class(TbsCustomShellChangeNotifier)
  published
    property NotifyFilters;
    property Root;
    property WatchSubTree;
    property OnChange;
  end;

  TbsCustomShellComboBox = class;
  TbsCustomShellListView = class;

  TAddFolderEvent = procedure(Sender: TObject; AFolder: TbsShellFolder;
    var CanAdd: Boolean) of object;
  TGetImageIndexEvent = procedure(Sender: TObject; Index: Integer;
     var ImageIndex: Integer) of object;

{ TbsCustomShellTreeView }

  TbsCustomShellTreeView = class(TbsSkinCustomTreeView, IShellCommandVerb)
  private
    FPath: String;
    FRoot,
    FOldRoot : TRoot;
    FRootFolder: TbsShellFolder;
    FObjectTypes: TShellObjectTypes;
    FLoadingRoot,
    FAutoContext,
    FUpdating: Boolean;
    FListView: TbsCustomShellListView;
    FComboBox: TbsCustomShellComboBox;
    FAutoRefresh,
    FImageListChanging,
    FUseShellImages: Boolean;
    FNotifier: TbsShellChangeNotifier;
    FOnAddFolder: TAddFolderEvent;
    FSavePath: string;
    FNodeToMonitor: TTreeNode;
    function FolderExists(FindID: PItemIDList; InNode: TTreeNode): TTreeNode;
    function GetFolder(Index: Integer): TbsShellFolder;
    function GetPath: string;
    procedure SetComboBox(Value: TbsCustomShellComboBox);
    procedure SetListView(const Value: TbsCustomShellListView);
    procedure SetPath(const Value: string);
    procedure SetPathFromID(ID: PItemIDList);
    procedure SetRoot(const Value: TRoot);
    procedure SetUseShellImages(const Value: Boolean);
    procedure SetAutoRefresh(const Value: boolean);
  protected
    function CanChange(Node: TTreeNode): Boolean; override;
    function CanExpand(Node: TTreeNode): Boolean; override;
    procedure CreateRoot;
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
    procedure DoContextPopup(MousePos: TPoint; var Handled: Boolean); override;
    procedure Edit(const Item: TTVItem); override;
    procedure GetImageIndex(Node: TTreeNode); override;
    procedure GetSelectedIndex(Node: TTreeNode); override;
    procedure InitNode(NewNode: TTreeNode; ID: PItemIDList; ParentNode: TTreeNode);
    procedure Loaded; override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure Delete(Node: TTreeNode); override;
    function NodeFromAbsoluteID(StartNode: TTreeNode; ID: PItemIDList): TTreeNode;
    function NodeFromRelativeID(ParentNode: TTreeNode; ID: PItemIDList): TTreeNode;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure PopulateNode(Node: TTreeNode);
    procedure RootChanged;
    procedure SetObjectTypes(Value: TShellObjectTypes); virtual;
    procedure WMDestroy(var Message: TWMDestroy); virtual;
    procedure WndProc(var Message: TMessage); override;
    procedure ClearItems;
    procedure RefreshEvent;
  public
    FImages: Integer;
    constructor Create(AOwner: TComponent); override;
    procedure Refresh(Node: TTreeNode);
    procedure ExpandMyComputer;
    function SelectedFolder: TbsShellFolder;
    property AutoRefresh: boolean read FAutoRefresh write SetAutoRefresh;
    property Folders[Index: Integer]: TbsShellFolder read GetFolder; default;
    property Items;
    property Path: string read GetPath write SetPath;
    property AutoContextMenus: Boolean read FAutoContext write FAutoContext default True;
    property ObjectTypes: TShellObjectTypes read FObjectTypes write SetObjectTypes;
    property Root: TRoot read FRoot write SetRoot;
    property ShellListView: TbsCustomShellListView read FListView write SetListView;
    property ShellComboBox: TbsCustomShellComboBox read FComboBox write SetComboBox;
    property UseShellImages: Boolean read FUseShellImages write SetUseShellImages;
    property OnAddFolder: TAddFolderEvent read FOnAddFolder write FOnAddFolder;
    procedure CommandCompleted(Verb: String; Succeeded: Boolean);
    procedure ExecuteCommand(Verb: String; var Handled: Boolean);
  end;

{ TShellTreeView }

  TbsSkinDirTreeView = class(TbsCustomShellTreeView)
  published
    property HScrollBar;