cxshelllistview.pas

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

{********************************************************************}
{                                                                    }
{       Developer Express Visual Component Library                   }
{       ExpressEditors                                               }
{                                                                    }
{       Copyright (c) 1998-2008 Developer Express Inc.               }
{       ALL RIGHTS RESERVED                                          }
{                                                                    }
{   The entire contents of this file is protected by U.S. and        }
{   International Copyright Laws. Unauthorized reproduction,         }
{   reverse-engineering, and distribution of all or any portion of   }
{   the code contained in this file is strictly prohibited and may   }
{   result in severe civil and criminal penalties and will be        }
{   prosecuted to the maximum extent possible under the law.         }
{                                                                    }
{   RESTRICTIONS                                                     }
{                                                                    }
{   THIS SOURCE CODE AND ALL RESULTING INTERMEDIATE FILES            }
{   (DCU, OBJ, DLL, ETC.) ARE CONFIDENTIAL AND PROPRIETARY TRADE     }
{   SECRETS OF DEVELOPER EXPRESS INC. THE REGISTERED DEVELOPER IS    }
{   LICENSED TO DISTRIBUTE THE EXPRESSEDITORS AND ALL                }
{   ACCOMPANYING VCL CONTROLS AS PART OF AN EXECUTABLE PROGRAM ONLY. }
{                                                                    }
{   THE SOURCE CODE CONTAINED WITHIN THIS FILE AND ALL RELATED       }
{   FILES OR ANY PORTION OF ITS CONTENTS SHALL AT NO TIME BE         }
{   COPIED, TRANSFERRED, SOLD, DISTRIBUTED, OR OTHERWISE MADE        }
{   AVAILABLE TO OTHER INDIVIDUALS WITHOUT EXPRESS WRITTEN CONSENT   }
{   AND PERMISSION FROM DEVELOPER EXPRESS INC.                       }
{                                                                    }
{   CONSULT THE END USER LICENSE AGREEMENT FOR INFORMATION ON        }
{   ADDITIONAL RESTRICTIONS.                                         }
{                                                                    }
{********************************************************************}

unit cxShellListView;

{$I cxVer.inc}

interface

uses
  Windows, Messages, Comctrls, Controls, Forms, Classes, Menus, ShlObj, StdCtrls,
  cxGraphics, cxContainer, cxDataUtils, cxCustomData, cxScrollBar,
  cxShellCommon, cxShellControls, cxHeader, cxLookAndFeels, cxLookAndFeelPainters;

type
  TcxShellObjectPathType = (sptAbsolutePhysical, sptRelativePhysical, sptUNC, sptVirtual,
    sptInternalAbsoluteVirtual, sptInternalRelativeVirtual, sptIncorrect);

  TcxShellViewOption = (svoShowFiles, svoShowFolders, svoShowHidden);
  TcxShellViewOptions = set of TcxShellViewOption;

  TcxCustomShellListView = class;

  TcxBeforeNavigationEvent = procedure(Sender: TcxCustomShellListView; ANewAbsolutePIDL: PItemIDList) of object;
  TcxCurrentFolderChangedEvent = procedure(Sender: TcxCustomShellListView) of object;

  { TcxInnerShellListView }

  TcxInnerShellListView = class(TcxCustomInnerShellListView, IUnknown,
    IcxContainerInnerControl)
  private
    FCanvas: TcxCanvas;
    FDefHeaderProc: Pointer;
    FHeaderHandle: HWND;
    FHeaderInstance: Pointer;
    FPressedHeaderItemIndex: Integer;
    FOnChange: TLVChangeEvent;

    // IcxContainerInnerControl
    function GetControl: TWinControl;
    function GetControlContainer: TcxContainer;
    // header
    function GetHeaderHotItemIndex: Integer;
    function GetHeaderItemRect(AItemIndex: Integer): TRect;
    function GetHeaderPressedItemIndex: Integer;
    function HeaderItemIndex(AHeaderItem: Integer): Integer;
    procedure HeaderWndProc(var Message: TMessage);
    procedure LVMGetHeaderItemInfo(var Message: TCMHeaderItemInfo); message CM_GETHEADERITEMINFO;

    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
    procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
    procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT;
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure DSMShellChangeNotify(var Message: TMessage); message DSM_SHELLCHANGENOTIFY;
  protected
    FContainer: TcxCustomShellListView;
    procedure Click; override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure DblClick; override;
    function DoCompare(AItem1, AItem2: TcxShellFolder;
      out ACompare: Integer): Boolean; override;
    function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
      MousePos: TPoint): Boolean; override;
    procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState;
      var Accept: Boolean); override;
    procedure DrawHeader; virtual;
    function GetPopupMenu: TPopupMenu; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure LookAndFeelChanged(Sender: TcxLookAndFeel;
      AChangedValues: TcxLookAndFeelValues); virtual; 
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure Navigate(APIDL: PItemIDList); override;
    procedure WndProc(var Message: TMessage); override;
    procedure ChangeHandler(Sender: TObject; AItem: TListItem;
      AChange: TItemChange); virtual;
    procedure MouseEnter(AControl: TControl); dynamic;
    procedure MouseLeave(AControl: TControl); dynamic;

    property Canvas: TcxCanvas read FCanvas;
    property Container: TcxCustomShellListView read FContainer;
    property OnChange: TLVChangeEvent read FOnChange write FOnChange;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure DefaultHandler(var Message); override;
    procedure DragDrop(Source: TObject; X, Y: Integer); override;
    function ExecuteAction(Action: TBasicAction): Boolean; override;
    function UpdateAction(Action: TBasicAction): Boolean; override;
{$IFDEF DELPHI5}
    function CanFocus: Boolean; override;
{$ENDIF}
  public
    property Align;
    property Anchors;
    property BorderStyle;
    property Color;
    property DragDropSettings;
    property HotTrack;
    property IconOptions;
    property Items;
    property ListViewStyle;
    property MultiSelect;
    property Options;
    property Root;
    property Visible;
    property AfterNavigation;
    property BeforeNavigation;
    property OnAddFolder;
    property OnCompare;
    property OnRootChanged;
    property OnSelectItem;
    property OnShellChange;
  end;

  { TcxCustomShellListView }

  TcxCustomShellListView = class(TcxContainer)
  private
    FInnerListView: TcxInnerShellListView;
    FIsExitProcessing: Boolean;
    FScrollBarsCalculating: Boolean;
    FOnAddFolder: TcxShellAddFolderEvent;
    FOnBeforeNavigation: TcxBeforeNavigationEvent;
    FOnChange: TLVChangeEvent;
    FOnCurrentFolderChanged: TcxCurrentFolderChangedEvent;
    FOnCompare: TcxShellCompareEvent;
    FOnSelectItem: TLVSelectItemEvent;
    FOnShellChange: TcxShellChangeEvent;

    procedure AddFolderHandler(Sender: TObject; AFolder: TcxShellFolder;
      var ACanAdd: Boolean);
    procedure BeforeNavigationHandler(Sender: TcxCustomInnerShellListView;
      APItemIDList: PItemIDList; AFolderPath: WideString);
    procedure ChangeHandler(Sender: TObject; Item: TListItem;
      Change: TItemChange);
    procedure SelectItemHandler(Sender: TObject; Item: TListItem;
      Selected: Boolean);
    procedure ShellChangeHandler(Sender: TObject; AEventID: DWORD;
      APIDL1, APIDL2: PItemIDList);

    function DoCompare(AItem1, AItem2: TcxShellFolder;
      out ACompare: Integer): Boolean;
    function GetAbsolutePIDL: PItemIDList;
    function GetDragDropSettings: TcxDragDropSettings;
    function GetFolder(AIndex: Integer): TcxShellFolder;
    function GetFolderCount: Integer;
    function GetIconOptions: TIconOptions;
    function GetListHotTrack: Boolean;
    function GetMultiSelect: Boolean;
    function GetOptions: TcxShellListViewOptions;
    function GetPath: string;
    function GetRoot: TcxShellListRoot;
    function GetShowColumnHeaders: Boolean;
    function GetViewStyle: TViewStyle;
    procedure SetAbsolutePIDL(Value: PItemIDList);
    procedure SetDragDropSettings(Value: TcxDragDropSettings);
    procedure SetIconOptions(Value: TIconOptions);
    procedure SetListHotTrack(Value: Boolean);
    procedure SetMultiSelect(Value: Boolean);
    procedure SetOptions(Value: TcxShellListViewOptions);
    procedure SetPath(Value: string);
    procedure SetRoot(Value: TcxShellListRoot);
    procedure SetShowColumnHeaders(Value: Boolean);
    procedure SetViewStyle(Value: TViewStyle);
  protected
    FDataBinding: TcxCustomDataBinding;
    procedure DoExit; override;
    procedure Loaded; override;
    procedure LookAndFeelChanged(Sender: TcxLookAndFeel;
      AChangedValues: TcxLookAndFeelValues); override;
    function NeedsScrollBars: Boolean; override;
    procedure Scroll(AScrollBarKind: TScrollBarKind; AScrollCode: TScrollCode;
      var AScrollPos: Integer); override;
    procedure CurrentFolderChangedHandler(Sender: TObject; Root: TcxCustomShellRoot); virtual;
    function GetDataBindingClass: TcxCustomDataBindingClass; virtual;
    function GetViewOptions(AForNavigation: Boolean = False): TcxShellViewOptions;
    procedure SetTreeView(ATreeView:TWinControl);
    property DataBinding: TcxCustomDataBinding read FDataBinding;
    property DragDropSettings: TcxDragDropSettings read GetDragDropSettings write SetDragDropSettings;
    property IconOptions: TIconOptions read GetIconOptions write SetIconOptions;
    property ListHotTrack: Boolean read GetListHotTrack write SetListHotTrack default False;
    property MultiSelect: Boolean read GetMultiSelect write SetMultiSelect default False;
    property Options: TcxShellListViewOptions read GetOptions write SetOptions;
    property Root: TcxShellListRoot read GetRoot write SetRoot;
    property ShowColumnHeaders: Boolean read GetShowColumnHeaders
      write SetShowColumnHeaders default True;
    property ViewStyle: TViewStyle read GetViewStyle write SetViewStyle default vsIcon;
    property OnAddFolder: TcxShellAddFolderEvent read FOnAddFolder
      write FOnAddFolder;
    property OnBeforeNavigation: TcxBeforeNavigationEvent read FOnBeforeNavigation write FOnBeforeNavigation;
    property OnChange: TLVChangeEvent read FOnChange write FOnChange;
    property OnCompare: TcxShellCompareEvent read FOnCompare write FOnCompare;
    property OnCurrentFolderChanged: TcxCurrentFolderChangedEvent
      read FOnCurrentFolderChanged write FOnCurrentFolderChanged;
    property OnSelectItem: TLVSelectItemEvent read FOnSelectItem write FOnSelectItem;
    property OnShellChange: TcxShellChangeEvent read FOnShellChange write FOnShellChange;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function ExecuteAction(Action: TBasicAction): Boolean; override;
    function UpdateAction(Action: TBasicAction): Boolean; override;
    procedure SetFocus; override;
    procedure BrowseParent;
    function GetItemAbsolutePIDL(AIndex: Integer): PItemIDList;
    procedure ProcessTreeViewNavigate(apidl:PItemIDList);
    procedure Sort;
    procedure UpdateContent;
    property AbsolutePath: string read GetPath write SetPath; // deprecated
    property AbsolutePIDL: PItemIDList read GetAbsolutePIDL write SetAbsolutePIDL;
    property FolderCount: Integer read GetFolderCount;
    property Folders[AIndex: Integer]: TcxShellFolder read GetFolder;
    property InnerListView: TcxInnerShellListView read FInnerListView;
    property Path: string read GetPath write SetPath;
  end;

  { TcxShellListView }

  TcxShellListView = class(TcxCustomShellListView)
  published
    property Align;
    property Anchors;
    property Constraints;
    property DragDropSettings;
    property Enabled;
    property IconOptions;
    property ListHotTrack;
    property MultiSelect;
    property Options;
    property ParentColor default False;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property Root;
    property ShowColumnHeaders;
    property ShowHint;
    property Style;
    property StyleDisabled;
    property StyleFocused;
    property StyleHot;
    property TabOrder;
    property TabStop;
    property ViewStyle;
    property Visible;
    property OnAddFolder;
    property OnBeforeNavigation;
    property OnChange;
    property OnClick;
    property OnCompare;
    property OnContextPopup;
    property OnCurrentFolderChanged;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnSelectItem;
    property OnShellChange;
    property OnStartDock;
    property OnStartDrag;
  end;

  TcxShellSpecialFolderInfoTableItem = record
    Attributes: ULONG;
    PIDL: PItemIDList;
    PIDLDisplayName, PIDLName, PIDLUpperCaseDisplayName: string;
  end;

function CheckAbsolutePIDL(var APIDL: PItemIDList; ARoot: TcxCustomShellRoot;
  ACheckObjectExistence: Boolean; ACheckIsSubPath: Boolean = True): Boolean;
function CheckShellObjectExistence(APIDL: PItemIDList): Boolean;
function CheckShellObjectPath(var APath: string; ACurrentPath: string;
  AIsDisplayText: Boolean): TcxShellObjectPathType;
function CheckViewOptions(AViewOptions: TcxShellViewOptions;
  AShellObjectAttributes: ULONG): Boolean;
function GetPIDLDisplayName(APIDL: PItemIDList; AShowFullPath: Boolean = False): string;
function InternalParseDisplayName(AParentIFolder: IShellFolder;
  ADisplayName: string; AViewOptions: TcxShellViewOptions): PItemIDList;
function PathToAbsolutePIDL(APath: string; ARoot: TcxCustomShellRoot;
  AViewOptions: TcxShellViewOptions; ACheckIsSubPath: Boolean = True): PItemIDList;
function ShellObjectInternalVirtualPathToPIDL(APath: string;
  ARoot: TcxCustomShellRoot; AViewOptions: TcxShellViewOptions): PItemIDList;

const
  cxShellSpecialFolderInfoTableLength = CSIDL_HISTORY - CSIDL_DESKTOP + 1;

var
  cxShellSpecialFolderInfoTable: array[CSIDL_DESKTOP..CSIDL_HISTORY] of
    TcxShellSpecialFolderInfoTableItem;

implementation

uses
{$IFDEF DELPHI6}
  Variants,
{$ENDIF}
  SysUtils, CommCtrl, ComObj, Graphics, ShellAPI, cxClasses, cxEdit,
  cxControls;

type
  TcxCustomDataBindingAccess = class(TcxCustomDataBinding);
  TcxContainerAccess = class(TcxContainer);
  TcxCustomShellRootAccess = class(TcxCustomShellRoot);

function CheckAbsolutePIDL(var APIDL: PItemIDList; ARoot: TcxCustomShellRoot;
  ACheckObjectExistence: Boolean; ACheckIsSubPath: Boolean = True): Boolean;
begin
  CheckShellRoot(ARoot);
  if APIDL = nil then
  begin
    Result := True;
    APIDL := ARoot.Pidl;
  end
  else
  begin
    Result := not ACheckIsSubPath or IsSubPath(ARoot.Pidl, APIDL);
    if Result and ACheckObjectExistence then
      Result := CheckShellObjectExistence(APIDL);
  end;
end;

function CheckShellObjectExistence(APIDL: PItemIDList): Boolean;
var
  ASHFileInfo: TSHFileInfo;
begin
  Result := SHGetFileInfo(PChar(APIDL), 0, ASHFileInfo, SizeOf(ASHFileInfo),
    SHGFI_PIDL or SHGFI_SYSICONINDEX or SHGFI_SMALLICON) <> 0;
end;

function CheckShellObjectPath(var APath: string; ACurrentPath: string;
  AIsDisplayText: Boolean): TcxShellObjectPathType;
var
  APathLength: Integer;
  S: string;
begin
  APathLength := Length(APath);
  Result := sptIncorrect;
  if APathLength = 0 then
    Exit;

  if (APathLength > 1) and (APath[APathLength] = '\') and (APath[APathLength - 1] <> ':') then
  begin
    Dec(APathLength);
    SetLength(APath, APathLength);
  end;

  if (APathLength > 2) and (APath[1] = '\') and (APath[2] = '\') then
  begin
    Result := sptUNC;
    Exit;
  end;
  if APathLength >= cxShellObjectInternalVirtualPathPrefixLength then
  begin
    S := AnsiUpperCase(Copy(APath, 1, cxShellObjectInternalVirtualPathPrefixLength));
    if S = cxShellObjectInternalAbsoluteVirtualPathPrefix then
    begin
      Result := sptInternalAbsoluteVirtual;
      Exit;
    end;
    if S = cxShellObjectInternalRelativeVirtualPathPrefix then
    begin
      Result := sptInternalRelativeVirtual;
      Exit;
    end;
    if Copy(S, 1, 3) = '::{' then
    begin
      Result := sptVirtual;
      Exit;
    end;
  end;
  if (Length(APath) >= 3) and (APath[2] = ':') and (APath[3] = '\') and
    (APath[1] in ['A'..'Z', 'a'..'z']) then
  begin
    Result := sptAbsolutePhysical;
    Exit;
  end;
  if (APath[1] = '\') or (Length(APath) >= 2) and (APath[2] = ':') and
    (APath[1] in ['A'..'Z', 'a'..'z']) then
  begin
    if (Length(ACurrentPath) < 3) or (ACurrentPath[2] <> ':') or
        (ACurrentPath[3] <> '\') or not(ACurrentPath[1] in ['A'..'Z', 'a'..'z']) then
      Exit;
    if (APath[1] <> '\') and (UpperCase(APath[1]) <> UpperCase(ACurrentPath[1])) then
      Exit;
    if (APath[1] <> '\') and (APathLength = 2) then
    begin
      if AIsDisplayText then
      begin
        APath := ACurrentPath;
        Result := sptAbsolutePhysical;
        Exit;