cxshellcommon.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 2,198 行 · 第 1/5 页

    property OpenIconIndex:Integer read FOpenIconIndex;
    property pidl:PItemIDList read Fpidl;
    property Updated:Boolean read FUpdated write FUpdated;
  end;

  PcxShellItemInfo = TcxShellItemInfo;

  { TcxShellItemsInfoGatherer }

  TcxShellItemsInfoGatherer = class
  private
    FFetchQueue: TList;
    FFetchStoppedEvent: THandle;
    FFetchThread: THandle;
    FIsFetchQueueClearing: Boolean;
    FOwner: TWinControl;
    FStopFetchCount: Integer;
    FStopFetchEvent: THandle;
    FTerminateFetchThreadEvent: THandle;
    procedure CreateFetchThread;
    function CreateRequestItem(AItemProducer: TcxCustomItemProducer;
      AIndex: Integer; APriority: Boolean): PcxRequestItem;
    function GetFetchQueueItemIndex(AFetchQueue: TList;
      AItemProducer: TcxCustomItemProducer; AIndex: Integer): Integer;
    function GetIsFetchStopping: Boolean;
    function GetIsFetchThreadTerminating: Boolean;
    procedure FetchResumed;
    procedure FetchStopped;
    procedure InternalCloseHandle(var AHandle: THandle);
    procedure TerminateFetchThread;
    property FetchQueue: TList read FFetchQueue;
    property IsFetchStopping: Boolean read GetIsFetchStopping;
    property IsFetchThreadTerminating: Boolean read GetIsFetchThreadTerminating;
  protected
    procedure DestroyFetchThread;
  public
    constructor Create(AOwner: TWinControl);
    destructor Destroy; override;
    procedure ClearFetchQueue(AItemProducer: TcxCustomItemProducer);
    procedure RequestItemInfo(AItemProducer: TcxCustomItemProducer;
      AIndex: Integer; APriority: Boolean);
    procedure ResumeFetch;
    procedure StopFetch;
  end;

  TcxCustomItemProducer=class
  private
    FDetails: TcxShellDetails;
    FFolderPidl: PItemIDList;
    FItems: TList;
    FItemsLock: TMultiReadExclusiveWriteSynchronizer;
    FOwner: TWinControl;
    FShellFolder: IShellFolder;
  protected
    function AllowBackgroundProcessing: Boolean; virtual; abstract;
    function CanAddFolder(AFolder: TcxShellFolder): Boolean; virtual;
    function DoCompareItems(AItem1, AItem2: TcxShellFolder;
      out ACompare: Integer): Boolean; virtual;
    procedure DoSort; virtual;
    procedure FetchItems(cPreloadItems:Integer);
    function GetEnumFlags:Cardinal;virtual;abstract;
    function GetItemsInfoGatherer: TcxShellItemsInfoGatherer; virtual; abstract;
    function GetShowToolTip:Boolean;virtual;abstract;
    procedure InitializeItem(Item:TcxShellItemInfo);virtual;
    procedure CheckForSubitems(AItem: TcxShellItemInfo); virtual;
    procedure ClearFetchQueue;
    property ItemsLock:TMultiReadExclusiveWriteSynchronizer read FItemsLock;
    property ShellFolder:IShellFolder read FShellFolder;
    property FolderPidl:PItemIDList read FFolderPidl write FFolderPidl;
    property Owner:TWinControl read FOwner;
  public
    constructor Create(AOwner:TWinControl);virtual;
    destructor Destroy;override;
    procedure ProcessItems(AIFolder: IShellFolder; AFolderPIDL: PItemIDList;
      cPreloadItems: Integer); virtual;
    procedure ProcessDetails(ShellFolder:IShellFolder;CharWidth:Integer);virtual;
    procedure FetchRequest(AIndex: Integer; APriority: Boolean = False);
    procedure ClearItems;
    procedure LockRead;
    procedure LockWrite;
    procedure UnlockRead;
    procedure UnlockWrite;
    procedure RequestItemsInfo;
    procedure SetItemsCount(Count:Integer);virtual;
    procedure NotifyUpdateItem(AItem: PcxRequestItem); virtual; abstract;
    procedure NotifyRemoveItem(Index:Integer);virtual;
    procedure NotifyAddItem(Index:Integer);virtual;
    procedure DoGetInfoTip(Handle:HWND;ItemIndex: Integer; InfoTip: PChar; cch:Integer);
    function GetItemByPidl(apidl:PItemIDList):TcxShellItemInfo;
    function GetItemIndexByPidl(apidl:PItemIDList):Integer;
    procedure Sort;
    property Details:TcxShellDetails read FDetails;
    property Items:TList read FItems;
    property ItemsInfoGatherer: TcxShellItemsInfoGatherer read GetItemsInfoGatherer;
  end;

  TcxDragDropSettings = class(TPersistent)
  private
    FAllowDragObjects: Boolean;
    FDefaultDropEffect: TcxDropEffect;
    FDropEffect: TcxDropEffectSet;
    FScroll: Boolean;
    FOnChange: TNotifyEvent;
    function GetDefaultDropEffectAPI: Integer;
    function GetDropEffectAPI: DWORD;
    procedure SetAllowDragObjects(Value: Boolean);
  protected
    procedure Changed;
  public
    property DropEffectAPI: DWORD read GetDropEffectApi;
    property DefaultDropEffectAPI: Integer read GetDefaultDropEffectAPI;
    constructor Create;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  published
    property AllowDragObjects: Boolean read FAllowDragObjects
      write SetAllowDragObjects default True;
    property DefaultDropEffect: TcxDropEffect read FDefaultDropEffect
      write FDefaultDropEffect default deMove;
    property DropEffect: TcxDropEffectSet read FDropEffect write FDropEffect
      default [deCopy, deMove, deLink];
    property Scroll: Boolean read FScroll write FScroll stored False; // deprecated
  end;

  TShChangeNotifyEntry = packed record
    pidlPath: PItemIDList;
    bWatchSubtree: BOOL;
  end;

  DWORDITEMID=record
    cb: SHORT;
    dwItem1: DWORD;
    dwItem2: DWORD;
  end;

  PDWORDITEMID=^DWORDITEMID;

  PShChangeNotifyEntry = ^TShChangeNotifyEntry;

function GetDesktopIShellFolder: IShellFolder;
function GetTextFromStrRet(var AStrRet: TStrRet; APIDL: PitemIDList): WideString;
function GetShellDetails(pFolder:IShellFolder;pidl:PItemIDList;out sd:IShellDetails):Hresult;
function HasSubItems(AParentIFolder: IShellFolder; AFullPIDL: PItemIDList;
  AEnumSettings: Cardinal): Boolean;
function cxFileTimeToDateTime(fTime:FILETIME):TDateTime;
function cxMalloc: IMalloc;
procedure DisplayContextMenu(AWnd: HWND; AIFolder: IShellFolder;
  AItemPIDLList: TList; const APos: TPoint);

{ Pidl Tools}

function GetPidlItemsCount(pidl:PItemIDList):Integer;
function GetPidlSize(pidl:PItemIDList):Integer;
function GetNextItemID(pidl:PItemIDList):PItemIDList;
function GetPidlCopy(pidl:PItemIDList):PItemIDList;
function GetLastPidlItem(pidl:PItemIDList):PItemIDList;
function GetPidlName(APIDL: PItemIDList): WideString;
function ConcatenatePidls(pidl1,pidl2:PItemIDList):PItemIDList;
procedure DisposePidl(pidl:PItemIDList);
function GetPidlParent(pidl:PItemIDList):PItemIDList;
function CreateEmptyPidl:PItemIDList;
function CreatePidlListFromList(List:TList):PItemIDList;
function ExtractParticularPidl(pidl:PItemIDList):PItemIDList;
function EqualPIDLs(APIDL1, APIDL2: PItemIDList): Boolean;
function IsSubPath(APIDL1, APIDL2: PItemIDList): Boolean;

{ Unicode Tools }

procedure StrPLCopyW(Dest:PWideChar;Source:WideString;MaxLen:Cardinal);
function StrPasW(Source:PWideChar):WideString;
function StrLenW(Source:PWideChar):Cardinal;
function UpperCaseW(Source:WideString):WideString;
function LowerCaseW(Source:WideString):WideString;

procedure CheckShellRoot(ARoot: TcxCustomShellRoot);
function GetShellItemDisplayName(AIFolder: IShellFolder;
  APIDL: PItemIDList; ACheckIsFolder: Boolean): WideString;

const
  DSM_SETCOUNT=CM_BASE+315;
  DSM_NOTIFYUPDATE=CM_BASE+316;
  DSM_NOTIFYREMOVEITEM=CM_BASE+318;
  DSM_NOTIFYADDITEM=CM_BASE+319;
  DSM_NOTIFYUPDATECONTENTS=CM_BASE+320;
  DSM_SHELLCHANGENOTIFY=CM_BASE+321;
  DSM_DONAVIGATE=CM_BASE+322;
  DSM_SYNCHRONIZEROOT=CM_BASE+323;
  DSM_SHELLTREECHANGENOTIFY=CM_BASE+324;
  DSM_SHELLTREERESTORECURRENTPATH=CM_BASE+325;

  PRELOAD_ITEMS_COUNT=10;

  SHCNF_ACCEPT_INTERRUPTS =     $1;
  SHCNF_ACCEPT_NON_INTERRUPTS = $2;
  SHCNF_NO_PROXY =              $8000;

var
  SHChangeNotifyRegister:function (hwnd:HWND;dwFlags:DWORD;wEventMask:DWORD;
           uMsg:UINT;cItems:DWORD;lpItems:PShChangeNotifyEntry):Cardinal;stdcall;
  SHChangeNotifyUnregister:function (hNotify:Cardinal):Boolean;stdcall;

implementation

uses
  cxContainer, cxControls, cxEdit, dxUxTheme;

const
  ShellLibraryName = 'shell32.dll';
{$IFNDEF DELPHI6}
  PathDelim  = '\';
  cxIID_IShellFolder2: TGUID = (
    D1:$93F2F68C; D2:$1D1B; D3:$11D3; D4:($A3,$0E,$00,$C0,$4F,$79,$AB,$D1));
{$ENDIF}
  SFGAO_ENCRYPTED       = $00002000;
  SFGAO_ISSLOW          = $00004000;
  SFGAO_STORAGE         = $00000008;
  SFGAO_STORAGEANCESTOR = $00800000;
  SFGAO_STORAGECAPMASK  = $70C50008;
  SFGAO_STREAM          = $00400000;

type
  TcxContextMenuMessageWindow = class(TcxMessageWindow)
  private
    FContextMenu: IContextMenu2;
  protected
    procedure WndProc(var Message: TMessage); override;
  public
    property ContextMenu: IContextMenu2 read FContextMenu write FContextMenu;
  end;

  TSHGetPathFromIDList = function(APIDL: PItemIDList; APath: PChar): BOOL; stdcall;
  TSHGetPathFromIDListW = function(APIDL: PItemIDList; APath: PWideChar): BOOL; stdcall;

{$IFDEF DELPHI6}
  cxIShellFolder2 = interface(IShellFolder2)
    ['{93F2F68C-1D1B-11D3-A30E-00C04F79ABD1}']
  end;
{$ENDIF}

var
  FSysFileIconIndex: Integer = -1;
  FSysFolderIconIndex: Integer = -1;
  FSysFolderOpenIconIndex: Integer = -1;
  cxSHGetFolderLocation:function (wnd:HWND;nFolder:Integer;hToken:THandle;
             dwReserwed:DWORD;var ppidl:PItemIDList):HResult;stdcall;
  cxSHGetPathFromIDList: TSHGetPathFromIDList = nil;
  cxSHGetPathFromIDListW: TSHGetPathFromIDListW = nil;
  ShellLibrary: HMODULE = 0;
  FcxMalloc: IMalloc;
  FShellItemsInfoGatherers: TList;

(*function GetShellItemDisplayName(AIFolder: IShellFolder;
  APIDL: PItemIDList; ACheckIsFolder: Boolean): WideString;
var
  AAttributes, AFlags: Cardinal;
  AIsFolder: Boolean;
  AStrRet: TStrRet;
begin
  Result := '';

  if ACheckIsFolder then
  begin
    AAttributes := SFGAO_FOLDER;
    if not Succeeded(AIFolder.GetAttributesOf(1, APIDL, AAttributes)) then
      Exit;
    AIsFolder := AAttributes and SFGAO_FOLDER <> 0;
  end
  else
    AIsFolder := False;

  AFlags := SHGDN_INFOLDER;
  if AIsFolder then
    AFlags := AFlags or SHGDN_FORPARSING;

  if not Succeeded(AIFolder.GetDisplayNameOf(APIDL, AFlags, AStrRet)) then
    Exit;
  Result := GetTextFromStrRet(AStrRet, APIDL);
  if AIsFolder and (Length(Result) > 2) then
    if (Result[1] = ':') and (Result[2] = ':') or
      (Result[1] = '\') and (Result[2] = '\') then
    begin
      AIFolder.GetDisplayNameOf(APIDL, SHGDN_INFOLDER, AStrRet);
      Result := GetTextFromStrRet(AStrRet, APIDL);
    end;
end;*)

procedure CheckShellRoot(ARoot: TcxCustomShellRoot);
begin
  if ARoot.ShellFolder = nil then
    ARoot.CheckRoot;
end;

function GetShellItemDisplayName(AIFolder: IShellFolder;
  APIDL: PItemIDList; ACheckIsFolder: Boolean): WideString;
var
  AStrRet: TStrRet;
begin
  if Succeeded(AIFolder.GetDisplayNameOf(APIDL, SHGDN_INFOLDER, AStrRet)) then
    Result := GetTextFromStrRet(AStrRet, APIDL)
  else
    Result := '';
end;

function HasSubItems(AParentIFolder: IShellFolder; AFullPIDL: PItemIDList;
  AEnumSettings: Cardinal): Boolean;

  function HasAttributes(AAttributes: UINT): Boolean;
  var
    ATempAttributes: UINT;
    ATempPIDL: PItemIDList;
  begin
    ATempAttributes := AAttributes;
    ATempPIDL := GetLastPidlItem(AFullPIDL);
    AParentIFolder.GetAttributesOf(1, ATempPIDL, ATempAttributes);
    Result := ATempAttributes and AAttributes = AAttributes;
  end;

  function CheckLocalFolder(out AHasSubItems: Boolean): Boolean;
  var
    AAttributes, AParsedCharCount: ULONG;
    ADesktopIFolder: IShellFolder;
    AFileSearchAttributes: Integer;
    ATempPIDL: PItemIDList;
    ASearchRec: TSearchRec;
    S: WideString;
  begin
    Result := False;
    S := GetPidlName(AFullPIDL);
    if (S = '')(* or (Pos('\\', S) = 1)*) then
      Exit;
    SHGetDesktopFolder(ADesktopIFolder);
    AAttributes := 0;
    ADesktopIFolder.ParseDisplayName(0, nil, PWideChar(S),
      AParsedCharCount, ATempPIDL, AAttributes);
    if ATempPIDL = nil then
      Exit;
    try
      Result := True;
      AHasSubItems := False;

      AFileSearchAttributes := faReadOnly or faSysFile or faArchive;
      if AEnumSettings and SHCONTF_FOLDERS <> 0 then
        AFileSearchAttributes := AFileSearchAttributes or faDirectory;
      if AEnumSettings and SHCONTF_INCLUDEHIDDEN <> 0 then
        AFileSearchAttributes := AFileSearchAttributes or faHidden;

      if S[Length(S)] = PathDelim then
        Delete(S, Length(S), 1);
      if FindFirst(S + PathDelim + '*.*', AFileSearchAttributes, ASearchRec) = 0 then
      begin
        repeat
          if (ASearchRec.Name = '.') or (ASearchRec.Name = '..') then
          begin
            if FindNext(ASearchRec) <> 0 then
              Break;
          end
          else
          begin
            AHasSubItems := True;
            Break;
          end;
        until False;
        FindClose(ASearchRec);
      end;
    finally
      DisposePidl(ATempPIDL);
    end;
  end;

var
  ATempIFolder: IShellFolder;
  ATempPIDL: PItemIDList;
  AIEnum: IEnumIDList;
  AFetchedItemCount: Cardinal;
begin
  Result := HasAttributes(SFGAO_FOLDER);
  if not Result then
    Exit;
//  if (AEnumSettings and SHCONTF_NONFOLDERS = 0) and AFast then
  if AEnumSettings and SHCONTF_NONFOLDERS = 0 then
    Result := HasAttributes(SFGAO_HASSUBFOLDER)
  else
  begin
    if CheckLocalFolder(Result) then
      Exit;
    Result := False;
    if Succeeded(AParentIFolder.BindToObject(GetLastPidlItem(AFullPIDL), nil, IID_IShellFolder,
      ATempIFolder)) then
        if ATempIFolder <> nil then
          if Succeeded(ATempIFolder.EnumObjects(0, AEnumSettings, AIEnum)) and Assigned(AIEnum) then
            if AIEnum.Next(1, ATempPIDL, AFetchedItemCount) = S_OK then
            try
              Result := AFetchedItemCount = 1;
            finally
              DisposePidl(ATempPIDL);
            end;
  end;
end;

function GetDesktopIShellFolder: IShellFolder;
begin
  OleCheck(SHGetDesktopFolder(Result));
end;

function GetTextFromStrRet(var AStrRet: TStrRet; APIDL: PitemIDList): WideString;
var
  P: PChar;
begin
  case AStrRet.uType of
    STRRET_CSTR:
      SetString(Result, AStrRet.cStr, lstrlen(AStrRet.cStr));
    STRRET_OFFSET:
      begin
        P := @APIDL.mkid.abID;
        Inc(P, AStrRet.uOffset - SizeOf(APIDL.mkid.cb));
        SetString(Result, P, APIDL.mkid.cb - AStrRet.uOffset);
      end;
    STRRET_WSTR:
      begin
        Result := StrPasW(AStrRet.pOleStr);
        cxMalloc.Free(AStrRet.pOleStr);
      end;
  end;
end;

function GetShellDetails(pFolder:IShellFolder;pidl:PItemIDList;out sd:IShellDetails):Hresult;
begin
  try
    Result := pFolder.QueryInterface(IID_IShellDetails, sd);
    if Result = S_OK then
       Exit;
    Result:=pFolder.GetUIObjectOf(0,0,pidl,IID_IShellDetails,nil,sd);
    if Result = S_OK then
       Exit;
    Result:=pFolder.CreateViewObject(0,IID_IShellDetails,sd);
    if Result = S_OK then
       Exit;
    Result:=pFolder.GetUIObjectOf(0,Integer(pidl<>nil)(*1*),pidl,IID_IShellDetails,nil,sd);
  finally
    if sd = nil then
      Result := E_NOINTERFACE;