acshellctrls.pas

Alpha Controls 5.40,delphi上的alpha开发源码控件包。没有密码。5.40版的最新版。

    property Ctl3D;
    property DragCursor;
    property DragKind;
    property DragMode;
    property DropDownCount;
    property Enabled;
    property Font;
    property ImeMode;
    property ImeName;
    property MaxLength;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property Images;
{$ENDIF} // NOTFORHELP
    property Root;
    property ShellTreeView;
    property ShellListView;
    property UseShellImages;
  end;

{ TacCustomShellListView }

{$IFNDEF NOTFORHELP}
  TacCustomShellListView = class(TsCustomListView, IacShellCommandVerb)
  private
    FOldRoot: TacRoot;
    FRoot: TacRoot;
    FRootFolder: TacShellFolder;
    FAutoContext, FAutoRefresh, FAutoNavigate, FSorted: Boolean;
    FObjectTypes: TacShellObjectTypes;
    FLargeImages, FSmallImages: Integer;
    FOnAddFolder: TacAddFolderEvent;
    FFolders: TList;
    FTreeView: TacCustomShellTreeView;
    FComboBox: TacCustomShellComboBox;
    FNotifier: TacShellChangeNotifier;
    FOnEditing: TLVEditingEvent;
    FSettingRoot: boolean;
    FSavePath: string;
    FMask: string;
    FShowExtension: TacShowExtension;
    procedure EnumColumns;
    function GetFolder(Index: Integer): TacShellFolder;
    procedure SetAutoRefresh(const Value: Boolean);
    procedure SetSorted(const Value: Boolean);
    procedure SetTreeView(Value: TacCustomShellTreeView);
    procedure SetComboBox(Value: TacCustomShellComboBox);
    procedure SynchPaths;
    procedure SetMask(const Value: string);
    function GetUpdating: boolean;
  protected
    procedure ClearItems;
    procedure CreateRoot;
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
    procedure DblClick; override;
    procedure DoContextPopup(MousePos: TPoint; var Handled: Boolean); override;
    procedure EditText;
    procedure Edit(const Item: TLVItem); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    function OwnerDataFetch(Item: TListItem; Request: TItemRequest): Boolean; override;
{$IFDEF TNTUNICODE}
    function OwnerDataFind(Find: TItemFind; const FindString: WideString;
{$ELSE}
    function OwnerDataFind(Find: TItemFind; const FindString: string;
{$ENDIF}
      const FindPosition: TPoint; FindData: Pointer; StartIndex: Integer; Direction: TSearchDirection; Wrap: Boolean): Integer; override;
    procedure Populate; virtual;
    procedure SetObjectTypes(Value: TacShellObjectTypes);
    procedure SetRoot(const Value: TacRoot);
    procedure WndProc(var Message: TMessage); override;
  public
    FUpdating: Boolean;
    procedure RootChanged;
    procedure SetPathFromID(ID: PItemIDList);
    procedure TreeUpdate(NewRoot: PItemIDList);
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
    procedure Back;
    procedure Refresh;
    procedure MakeNewFolder;
    function SelectedFolder: TacShellFolder;
    procedure CommandCompleted(Verb: String; Succeeded: Boolean);
    procedure ExecuteCommand(Verb: String; var Handled: Boolean);
    property Folders[Index: Integer]: TacShellFolder read GetFolder;
    property RootFolder: TacShellFolder read FRootFolder;
    property Items;
    property Columns;
    property Mask: string read FMask write SetMask;
    property AutoContextMenus: Boolean read FAutoContext write FAutoContext default True;
    property AutoRefresh: Boolean read FAutoRefresh write SetAutoRefresh default False;
    property AutoNavigate: Boolean read FAutoNavigate write FAutoNavigate default True;
    property ObjectTypes: TacShellObjectTypes read FObjectTypes write SetObjectTypes;
    property Root: TacRoot read FRoot write SetRoot;
    property ShellTreeView: TacCustomShellTreeView read FTreeView write SetTreeView;
    property ShellComboBox: TacCustomShellComboBox read FComboBox write SetComboBox;
    property Sorted: Boolean read FSorted write SetSorted;
    property Updating : boolean read GetUpdating;
    //Lexa
    property ShowExt: TacShowExtension read FShowExtension write FShowExtension;
    property OnAddFolder: TacAddFolderEvent read FOnAddFolder write FOnAddFolder;
    property OnEditing: TLVEditingEvent read FOnEditing write FOnEditing;
  end;
{$ENDIF} // NOTFORHELP

{ TShellListView }

  TsShellListView = class(TacCustomShellListView)
  published
{$IFNDEF NOTFORHELP}
    property OnChange;
    property OnChanging;
    property OnColumnClick;
    property OnContextPopup;
    property OnEnter;
    property OnExit;
    property OnInsert;
    property OnDragDrop;
    property OnDragOver;
    property DragCursor;
    property OnStartDrag;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;

    property Align;
    property Anchors;
    property BorderStyle;
    property Color;
    property ColumnClick;
    property OnClick;
    property OnDblClick;
    property Ctl3D;
    property DragMode;
    property ReadOnly default True;
    property Enabled;
    property Font;
    property GridLines;
    property Sorted;
    property HideSelection;
    property HotTrack;
    property IconOptions;
    property AllocBy;
    property MultiSelect;
    property RowSelect;
    property ParentColor default False;
    property ParentFont;
    property ParentShowHint;
    property ShowHint;
    property PopupMenu;
    property TabOrder;
    property TabStop default True;
    property Visible;
    property ViewStyle;
    {:@event}
    property OnEditing;
    {:@event}
    property OnAddFolder;
{$ENDIF} // NOTFORHELP
    property AutoContextMenus;
    property AutoRefresh;
    property AutoNavigate;
    property ObjectTypes;
    property Root;
    property ShellTreeView;
    property ShellComboBox;
    property ShowExt;
    property Mask;
    property ShowColumnHeaders;
  end;

{$IFNDEF NOTFORHELP}
  TsDlgShellListView = class(TsShellListView)
  protected
    procedure DblClick; override;
  end;

function G_ValidateMask(const S, Mask: string; MaskChar: Char = 'X'): Boolean;
function G_ValidateWildText(const S, Mask: string; MaskChar: Char = '?'; WildCard: Char = '*'): Boolean;
function G_CharPos(C: Char; const S: string; StartPos: Integer = 1): Integer; overload;
procedure DisposePIDL(PIDL: PItemIDList);

procedure InvokeContextMenu(Owner: TWinControl; AFolder: TacShellFolder; X, Y: Integer);

var
  DontFoldersGenerate : boolean = False;

const
  SRFDesktop = 'rfDesktop'; { Do not localize }
  SCmdVerbOpen = 'open'; { Do not localize }
  SCmdVerbRename = 'rename'; { Do not localize }
  SCmdVerbDelete = 'delete'; { Do not localize }
  SCmdVerbPaste = 'paste'; { Do not localize }
  SShellNoDetails = 'Unable to retrieve folder details for "%s". Error code $%x';
{$ENDIF} // NOTFORHELP

implementation

uses ShellAPI, ComObj, TypInfo, Menus, Consts, Math, sMessages, sVclUtils, // sGraphUtils,
  acntUtils, FileCtrl, acSBUtils{$IFDEF TNTUNICODE}, TntComCtrls, TntClasses{$ENDIF};
  
{$I sDefs.inc}

const
  nFolder: array[TacRootFolder] of Integer = (CSIDL_DESKTOP, CSIDL_DRIVES,
    CSIDL_NETWORK, CSIDL_BITBUCKET, CSIDL_APPDATA, CSIDL_COMMON_DESKTOPDIRECTORY,
    CSIDL_COMMON_PROGRAMS, CSIDL_COMMON_STARTMENU, CSIDL_COMMON_STARTUP,
    CSIDL_CONTROLS, CSIDL_DESKTOPDIRECTORY, CSIDL_FAVORITES, CSIDL_FONTS,
    CSIDL_INTERNET, CSIDL_PERSONAL, CSIDL_PRINTERS, CSIDL_PRINTHOOD, CSIDL_PROGRAMS,
    CSIDL_RECENT, CSIDL_SENDTO, CSIDL_STARTMENU, CSIDL_STARTUP, CSIDL_TEMPLATES);

var
  cmvProperties: PChar = 'properties';  { Do not localize }
  ICM: IContextMenu = nil;
  ICM2: IContextMenu2 = nil;
  DesktopFolder: TacShellFolder = nil;
  CS : TRTLCriticalSection;
  SmallImages : TImageList;

{ PIDL manipulation }

function CreatePIDL(Size: Integer): PItemIDList;
var
  Malloc: IMalloc;
begin
  OleCheck(SHGetMalloc(Malloc));
  Result := Malloc.Alloc(Size);
  if Assigned(Result) then FillChar(Result^, Size, 0);
end;

function NextPIDL(IDList: PItemIDList): PItemIDList;
begin
  Result := IDList;
  Inc(PChar(Result), IDList^.mkid.cb);
end;

procedure StripLastID(IDList: PItemIDList);
var
  MarkerID: PItemIDList;
begin
  MarkerID := IDList;
  if Assigned(IDList) then begin
    while IDList.mkid.cb <> 0 do begin
      MarkerID := IDList;
      IDList := NextPIDL(IDList);
    end;
    MarkerID.mkid.cb := 0;
  end;
end;

function GetItemCount(IDList: PItemIDList): Integer;
begin
  Result := 0;
  while IDList^.mkid.cb <> 0 do begin
    Inc(Result);
    IDList := NextPIDL(IDList);
  end;
end;

function GetPIDLSize(IDList: PItemIDList): Integer;
begin
  Result := 0;
  if Assigned(IDList) then begin
    Result := SizeOf(IDList^.mkid.cb);
    while IDList^.mkid.cb <> 0 do begin
      Result := Result + IDList^.mkid.cb;
      IDList := NextPIDL(IDList);
    end;
  end;
end;

function CopyPIDL(IDList: PItemIDList): PItemIDList;
var
  Size: Integer;
begin
  Size := GetPIDLSize(IDList);
  Result := CreatePIDL(Size);
  if Assigned(Result) then CopyMemory(Result, IDList, Size);
end;

function ConcatPIDLs(IDList1, IDList2: PItemIDList): PItemIDList;
var
  cb1, cb2: Integer;
begin
  if Assigned(IDList1) then cb1 := GetPIDLSize(IDList1) - SizeOf(IDList1^.mkid.cb) else cb1 := 0;

  cb2 := GetPIDLSize(IDList2);

  Result := CreatePIDL(cb1 + cb2);
  if Assigned(Result) then begin
    if Assigned(IDList1) then CopyMemory(Result, IDList1, cb1);
    CopyMemory(PChar(Result) + cb1, IDList2, cb2);
  end;
end;

procedure DisposePIDL(PIDL: PItemIDList);
var
  MAlloc: IMAlloc;
begin
  OLECheck(SHGetMAlloc(MAlloc));
  MAlloc.Free(PIDL);
end;

function RelativeFromAbsolute(AbsoluteID: PItemIDList): PItemIDList;
begin
  Result := AbsoluteID;
  while GetItemCount(Result) > 1 do Result := NextPIDL(Result);
  Result := CopyPIDL(Result);
end;

function CreatePIDLList(ID: PItemIDList): TList;
var
  TempID: PItemIDList;
begin
  Result := TList.Create;
  TempID := ID;
  while TempID.mkid.cb <> 0 do begin
    TempID := CopyPIDL(TempID);
    Result.Insert(0, TempID); //0 = lowest level PIDL.
    StripLastID(TempID);
  end;
end;

procedure DestroyPIDLList(List: TList);
var
  I: Integer;
begin
  If List = nil then Exit;
  for I := 0 to List.Count-1 do DisposePIDL(List[I]);
  List.Free;
end;

{ Miscellaneous }

procedure NoFolderDetails(AFolder: TacShellFolder; HR: HResult; ShowExt: TacShowExtension);
begin
  Raise Exception.CreateFmt(SShellNoDetails, [AFolder.DisplayName(ShowExt), HR]);
end;

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

procedure CreateDesktopFolder;
var
  DesktopPIDL: PItemIDList;
begin
  SHGetSpecialFolderLocation(0, nFolder[rfDesktop], DesktopPIDL);
  if DesktopPIDL <> nil then begin
    DesktopFolder := TacShellFolder.Create(nil, DesktopPIDL, DesktopShellFolder);
    DisposePIDL(DesktopPIDL);
  end;
end;

function SamePIDL(ID1, ID2: PItemIDList): boolean;
begin
  Result := DesktopShellFolder.CompareIDs(0, ID1, ID2) = 0;
end;

function DesktopPIDL: PItemIDList;
begin
  OleCheck(SHGetSpecialFolderLocation(0, nFolder[rfDesktop], Result));
end;

function GetCSIDLType(const Value: string): TacRootFolder;
begin
{$R+}
  Result := TacRootFolder(GetEnumValue(TypeInfo(TacRootFolder), Value))
{$R-}
end;

function IsElement(Element, Flag: Integer): Boolean;
begin
  Result := Element and Flag <> 0;
end;