foldertreeview.pas

源代码

unit FolderTreeView;

{
  Inno Setup
  Copyright (C) 1997-2004 Jordan Russell
  Portions by Martijn Laan
  For conditions of distribution and use, see LICENSE.TXT.

  TFolderTreeView component

  $jrsoftware: issrc/Components/FolderTreeView.pas,v 1.19 2004/02/13 10:18:21 jr Exp $
}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, CommCtrl;

type
  TCustomFolderTreeView = class;

  TFolderRenameEvent = procedure(Sender: TCustomFolderTreeView;
    var NewName: String; var Accept: Boolean) of object;

  TCustomFolderTreeView = class(TWinControl)
  private
    FDirectory: String;
    FFriendlyTree: Boolean;
    FInPaint: Boolean;
    FOnChange: TNotifyEvent;
    FOnRename: TFolderRenameEvent;
    procedure Change;
    procedure DeleteObsoleteNewItems(const ParentItem, ItemToKeep: HTREEITEM);
    function FindItem(const ParentItem: HTREEITEM; const AName: String): HTREEITEM;
    function FindOrCreateItem(const ParentItem: HTREEITEM; const AName: String): HTREEITEM;
    function GetItemFullPath(Item: HTREEITEM): String;
    function InsertItem(const ParentItem: HTREEITEM; const AName, ACustomDisplayName: String;
      const ANewItem, AReadProperDisplayName: Boolean): HTREEITEM;
    procedure SelectItem(const Item: HTREEITEM);
    procedure SetItemHasChildren(const Item: HTREEITEM; const AHasChildren: Boolean);
    procedure SetDirectory(const Value: String);
    procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
    procedure WMCtlColorEdit(var Message: TMessage); message WM_CTLCOLOREDIT;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  protected
    procedure ItemChildrenNeeded(const Item: HTREEITEM); virtual; abstract;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    function GetItemImageIndex(const Item: HTREEITEM;
      const NewItem, SelectedImage: Boolean): Integer; virtual; abstract;
    function GetRootItem: HTREEITEM; virtual;
    function ItemHasChildren(const Item: HTREEITEM): Boolean; virtual; abstract;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnRename: TFolderRenameEvent read FOnRename write FOnRename;
  public
    constructor Create(AOwner: TComponent); override;
    procedure ChangeDirectory(const Value: String; const CreateNewItems: Boolean);
    procedure CreateNewDirectory(const ADefaultName: String);
    property Directory: String read FDirectory write SetDirectory;
  end;

  TFolderTreeView = class(TCustomFolderTreeView)
  protected
    procedure ItemChildrenNeeded(const Item: HTREEITEM); override;
    function ItemHasChildren(const Item: HTREEITEM): Boolean; override;
    function GetItemImageIndex(const Item: HTREEITEM;
      const NewItem, SelectedImage: Boolean): Integer; override;
  published
    property TabOrder;
    property TabStop default True;
    property Visible;
    property OnChange;
    property OnRename;
  end;

  TStartMenuFolderTreeView = class(TCustomFolderTreeView)
  private
    FUserPrograms, FCommonPrograms: String;
    FUserStartup, FCommonStartup: String;
    FImageIndexes: array[Boolean] of Integer;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    function GetRootItem: HTREEITEM; override;
    procedure ItemChildrenNeeded(const Item: HTREEITEM); override;
    function ItemHasChildren(const Item: HTREEITEM): Boolean; override;
    function GetItemImageIndex(const Item: HTREEITEM;
      const NewItem, SelectedImage: Boolean): Integer; override;
  public
    procedure SetPaths(const AUserPrograms, ACommonPrograms,
      AUserStartup, ACommonStartup: String);
  published
    property TabOrder;
    property TabStop default True;
    property Visible;
    property OnChange;
    property OnRename;
  end;

procedure Register;

implementation

{
  Notes:
  1. Don't call TreeView_SelectItem without calling TreeView_Expand on the
     item's parents first. Otherwise infinite recursion can occur:
     TreeView_SelectItem will send a TVN_ITEMEXPANDING message and if the
     message handler calls TreeView_SortChildren, another (nested)
     TVN_ITEMEXPANDING message gets sent for some reason. Probably a COMCTL32
     bug. (It's reproducable on Windows 95 and 2000.)
}

uses
  PathFunc, ShellApi;

procedure Register;
begin
  RegisterComponents('JR', [TFolderTreeView, TStartMenuFolderTreeView]);
end;

function IsListableDirectory(const FindData: TWin32FindData): Boolean;
begin
  Result := (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0) and
    (FindData.dwFileAttributes and (FILE_ATTRIBUTE_HIDDEN or FILE_ATTRIBUTE_SYSTEM) <>
     (FILE_ATTRIBUTE_HIDDEN or FILE_ATTRIBUTE_SYSTEM)) and
    (StrComp(FindData.cFileName, '.') <> 0) and
    (StrComp(FindData.cFileName, '..') <> 0);
end;

function HasSubfolders(const Path: String): Boolean;
var
  H: THandle;
  FindData: TWin32FindData;
begin
  Result := False;
  H := FindFirstFile(PChar(AddBackslash(Path) + '*'), FindData);
  if H <> INVALID_HANDLE_VALUE then begin
    try
      repeat
        if IsListableDirectory(FindData) then begin
          Result := True;
          Break;
        end;
      until not FindNextFile(H, FindData);
    finally
      Windows.FindClose(H);
    end;
  end;
end;

function GetFileDisplayName(const Filename: String): String;
var
  FileInfo: TSHFileInfo;
begin
  if SHGetFileInfo(PChar(Filename), 0, FileInfo, SizeOf(FileInfo),
     SHGFI_DISPLAYNAME) <> 0 then
    Result := FileInfo.szDisplayName
  else
    Result := '';
end;

function GetFileImageIndex(const Filename: String; const OpenIcon: Boolean): Integer;
const
  OpenFlags: array[Boolean] of UINT = (0, SHGFI_OPENICON);
var
  FileInfo: TSHFileInfo;
begin
  if SHGetFileInfo(PChar(Filename), 0, FileInfo, SizeOf(FileInfo),
     SHGFI_SYSICONINDEX or SHGFI_SMALLICON or OpenFlags[OpenIcon]) <> 0 then
    Result := FileInfo.iIcon
  else
    Result := 0;
end;

function GetDefFolderImageIndex(const OpenIcon: Boolean): Integer;
const
  OpenFlags: array[Boolean] of UINT = (0, SHGFI_OPENICON);
var
  FileInfo: TSHFileInfo;
begin
  if SHGetFileInfo('c:\directory', FILE_ATTRIBUTE_DIRECTORY, FileInfo, SizeOf(FileInfo),
     SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX or SHGFI_SMALLICON or OpenFlags[OpenIcon]) <> 0 then
    Result := FileInfo.iIcon
  else
    Result := 0;
end;

function UseFriendlyTree: Boolean;
var
  Ver: Word;
  K: HKEY;
  Typ, Value, Size: DWORD;
begin
  { Running Windows XP or later? }
  Ver := Word(GetVersion);
  if (Lo(Ver) > 5) or ((Lo(Ver) = 5) and (Hi(Ver) >= 1)) then begin
    Result := True;
    if RegOpenKeyEx(HKEY_CURRENT_USER,
       'Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced',
       0, KEY_QUERY_VALUE, K) = ERROR_SUCCESS then begin
      Size := SizeOf(Value);
      if (RegQueryValueEx(K, 'FriendlyTree', nil, @Typ, @Value, @Size) = ERROR_SUCCESS) and
         (Typ = REG_DWORD) and (Size = SizeOf(Value)) then
        Result := (Value <> 0);
      RegCloseKey(K);
    end;
  end
  else
    Result := False;
end;

{ TCustomFolderTreeView }

type
  PItemData = ^TItemData;
  TItemData = record
    Name, DisplayName: String;
    NewItem: Boolean;
    ProperDisplayNameSet, ChildrenAdded: Boolean;
  end;

constructor TCustomFolderTreeView.Create(AOwner: TComponent);
begin
  inherited;
  ControlStyle := ControlStyle - [csCaptureMouse];
  Width := 121;
  Height := 97;
  ParentColor := False;
  TabStop := True;
  Cursor := crArrow;  { prevent hand cursor from appearing in TVS_TRACKSELECT mode }
end;

procedure TCustomFolderTreeView.CreateParams(var Params: TCreateParams);
const
  TVS_TRACKSELECT = $0200;
  TVS_SINGLEEXPAND = $0400;
begin
  InitCommonControls;
  inherited;
  CreateSubClass(Params, WC_TREEVIEW);
  with Params do begin
    Style := Style or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or TVS_LINESATROOT or
      TVS_HASBUTTONS or TVS_SHOWSELALWAYS or TVS_EDITLABELS;
    FFriendlyTree := UseFriendlyTree;
    if FFriendlyTree then
      Style := Style or TVS_TRACKSELECT or TVS_SINGLEEXPAND
    else
      Style := Style or TVS_HASLINES;
    ExStyle := ExStyle or WS_EX_CLIENTEDGE;
    WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  end;
end;

procedure TCustomFolderTreeView.CreateWnd;
var
  ImageList: HIMAGELIST;
  FileInfo: TSHFileInfo;
begin
  inherited;
  FDirectory := '';
  if csDesigning in ComponentState then
    Exit;

  { Initialize the image list }
  ImageList := SHGetFileInfo('', 0, FileInfo, SizeOf(FileInfo),
    SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
  TreeView_SetImageList(Handle, ImageList, TVSIL_NORMAL);

  ItemChildrenNeeded(nil);
end;

procedure TCustomFolderTreeView.KeyDown(var Key: Word; Shift: TShiftState);
var
  Item: HTREEITEM;
begin
  inherited;
  if (Key = VK_F2) and (Shift * [ssShift, ssAlt, ssCtrl] = []) then begin
    Key := 0;
    Item := TreeView_GetSelection(Handle);
    if Assigned(Item) then
      TreeView_EditLabel(Handle, Item);
  end;
end;

procedure TCustomFolderTreeView.WMPaint(var Message: TWMPaint);
begin
  FInPaint := True;
  try
    inherited;
  finally
    FInPaint := False;
  end;
end;

procedure TCustomFolderTreeView.WMCtlColorEdit(var Message: TMessage);
begin
  { We can't let TWinControl.DefaultHandler handle this message. It tries to
    send a CN_CTLCOLOREDIT message to the tree view's internally-created edit
    control, which it won't understand because it's not a VCL control. Without
    this special handling, the border is painted incorrectly on Windows XP
    with themes enabled. }
  Message.Result := DefWindowProc(Handle, Message.Msg, Message.WParam,
    Message.LParam);
end;

function TCustomFolderTreeView.GetItemFullPath(Item: HTREEITEM): String;
var
  TVItem: TTVItem;
begin
  Result := '';
  while Assigned(Item) do begin
    TVItem.mask := TVIF_PARAM;
    TVItem.hItem := Item;
    if not TreeView_GetItem(Handle, TVItem) then begin
      Result := '';
      Exit;
    end;
    if Result = '' then
      Result := PItemData(TVItem.lParam).Name
    else
      Insert(AddBackslash(PItemData(TVItem.lParam).Name), Result, 1);
    Item := TreeView_GetParent(Handle, Item);
  end;
end;

procedure TCustomFolderTreeView.Change;
var
  Item: HTREEITEM;
begin
  Item := TreeView_GetSelection(Handle);
  if Assigned(Item) then
    FDirectory := GetItemFullPath(Item)
  else
    FDirectory := '';
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

procedure TCustomFolderTreeView.CNNotify(var Message: TWMNotify);
const
  TVN_SINGLEEXPAND = (TVN_FIRST-15);
  TVNRET_SKIPOLD = 1;
  TVNRET_SKIPNEW = 2;

  procedure HandleClick;
  var
    Item: HTREEITEM;
    HitTestInfo: TTVHitTestInfo;
  begin
    HitTestInfo.pt := ScreenToClient(SmallPointToPoint(TSmallPoint(GetMessagePos())));
    Item := TreeView_HitTest(Handle, HitTestInfo);
    if Assigned(Item) then begin
      if HitTestInfo.flags and TVHT_ONITEMBUTTON <> 0 then
        TreeView_Expand(Handle, Item, TVE_TOGGLE)
      else begin
        SelectItem(Item);
        if FFriendlyTree and (HitTestInfo.flags and TVHT_ONITEM <> 0) then
          TreeView_Expand(Handle, Item, TVE_EXPAND);
      end;
    end;
  end;

var
  Hdr: PNMTreeView;
  SaveCursor: HCURSOR;
  DispItem: PTVItem;
  TVItem: TTVItem;
  S: String;
  Accept: Boolean;
begin
  inherited;
  case Message.NMHdr.code of
    TVN_DELETEITEM:
      begin
        Dispose(PItemData(PNMTreeView(Message.NMHdr).itemOld.lParam));
      end;
    TVN_ITEMEXPANDING:
      begin
        Hdr := PNMTreeView(Message.NMHdr);
        if (Hdr.action = TVE_EXPAND) and
           not PItemData(Hdr.itemNew.lParam).ChildrenAdded and
           not PItemData(Hdr.itemNew.lParam).NewItem then begin
          PItemData(Hdr.itemNew.lParam).ChildrenAdded := True;
          SaveCursor := SetCursor(LoadCursor(0, IDC_WAIT));
          try
            ItemChildrenNeeded(Hdr.itemNew.hItem);
            { If no subfolders were found, and there are no 'new' items
              underneath the parent item, remove the '+' sign }
            if TreeView_GetChild(Handle, Hdr.itemNew.hItem) = nil then
              SetItemHasChildren(Hdr.itemNew.hItem, False);
          finally
            SetCursor(SaveCursor);
          end;
        end;
      end;
    TVN_GETDISPINFO:
      begin
        DispItem := @PTVDispInfo(Message.NMHdr).item;
        TVItem.mask := 0;
        TVItem.hItem := DispItem.hItem;
        if DispItem.mask and TVIF_TEXT <> 0 then begin
          { On drives, read the proper display name if needed, and only if the
            control is painting (to avoid spinning up CD-ROMs when control
            isn't visible) }
          if not PItemData(DispItem.lParam).ProperDisplayNameSet and FInPaint then begin
            PItemData(DispItem.lParam).ProperDisplayNameSet := True;
            S := GetFileDisplayName(GetItemFullPath(DispItem.hItem));
            if S <> '' then
              PItemData(DispItem.lParam).DisplayName := S;
          end;
          StrPLCopy(DispItem.pszText, PItemData(DispItem.lParam).DisplayName,
            DispItem.cchTextMax-1);
        end;
        if DispItem.mask and TVIF_IMAGE <> 0 then begin
          TVItem.mask := TVItem.mask or TVIF_IMAGE;
          TVItem.iImage := GetItemImageIndex(DispItem.hItem,
            PItemData(DispItem.lParam).NewItem, False);
          DispItem.iImage := TVItem.iImage;
        end;
        if DispItem.mask and TVIF_SELECTEDIMAGE <> 0 then begin
          TVItem.mask := TVItem.mask or TVIF_SELECTEDIMAGE;
          TVItem.iSelectedImage := GetItemImageIndex(DispItem.hItem,
            PItemData(DispItem.lParam).NewItem, True);
          DispItem.iSelectedImage := TVItem.iSelectedImage;
        end;
        if DispItem.mask and TVIF_CHILDREN <> 0 then begin
          TVItem.mask := TVItem.mask or TVIF_CHILDREN;
          TVItem.cChildren := Ord(Assigned(TreeView_GetChild(Handle, DispItem.hItem)));
          if (TVItem.cChildren = 0) and not PItemData(DispItem.lParam).NewItem then
            TVitem.cChildren := Ord(ItemHasChildren(DispItem.hItem));
          DispItem.cChildren := TVItem.cChildren;
        end;
        { Store the values with the item so the callback isn't called again }
        if TVItem.mask <> 0 then
          TreeView_SetItem(Handle, TVItem);
      end;
    TVN_SELCHANGED:
      begin
        Change;
      end;
    TVN_BEGINLABELEDIT:
      begin
        DispItem := @PTVDispInfo(Message.NMHdr).item;
        { Only 'new' items may be renamed }
        if not PItemData(DispItem.lParam).NewItem then
          Message.Result := 1;
      end;
    TVN_ENDLABELEDIT:
      begin
        DispItem := @PTVDispInfo(Message.NMHdr).item;
        { Only 'new' items may be renamed }
        if PItemData(DispItem.lParam).NewItem and
           Assigned(DispItem.pszText) then begin
          S := DispItem.pszText;
          Accept := True;
          if Assigned(FOnRename) then
            FOnRename(Self, S, Accept);
          if Accept then begin
            PItemData(DispItem.lParam).Name := S;