foldertreeview.pas

源代码

            PItemData(DispItem.lParam).DisplayName := S;
            TreeView_SortChildren(Handle, TreeView_GetParent(Handle, DispItem.hItem), 0);
            Change;
          end;
        end;
      end;
    NM_CLICK:
      begin
        { Use custom click handler to work more like Windows XP Explorer:
          - Items can be selected by clicking anywhere on their respective
            rows, except for the button.
          - In 'friendly tree' mode, clicking an item's icon or caption causes
            the item to expand, but never to collapse. }
        HandleClick;
        Message.Result := 1;
      end;
    TVN_SINGLEEXPAND:
      begin
        Hdr := PNMTreeView(Message.NMHdr);
        { Trying to emulate Windows XP's Explorer here:
          Only collapse old item if it's at the same level as the new item. }
        if Assigned(Hdr.itemOld.hItem) and Assigned(Hdr.itemNew.hItem) and
           (TreeView_GetParent(Handle, Hdr.itemNew.hItem) <>
            TreeView_GetParent(Handle, Hdr.itemOld.hItem)) then
          Message.Result := Message.Result or TVNRET_SKIPOLD;
        { Selecting expanded items shouldn't collapse them }
        if Assigned(Hdr.itemNew.hItem) then begin
          TVItem.mask := TVIF_STATE;
          TVItem.hItem := Hdr.itemNew.hItem;
          TVItem.stateMask := TVIS_EXPANDED;
          if TreeView_GetItem(Handle, TVItem) and
             (TVItem.state and TVIS_EXPANDED <> 0) then
            Message.Result := Message.Result or TVNRET_SKIPNEW;
        end;
      end;
  end;
end;

procedure TCustomFolderTreeView.SetItemHasChildren(const Item: HTREEITEM;
  const AHasChildren: Boolean);
var
  TVItem: TTVItem;
begin
  TVItem.mask := TVIF_CHILDREN;
  TVItem.hItem := Item;
  TVItem.cChildren := Ord(AHasChildren);
  TreeView_SetItem(Handle, TVItem);
end;

procedure TCustomFolderTreeView.DeleteObsoleteNewItems(const ParentItem,
  ItemToKeep: HTREEITEM);
{ Destroys all 'new' items except for ItemToKeep and its parents. (ItemToKeep
  doesn't necessarily have to be a 'new' item.) Pass nil in the ParentItem
  parameter when calling this method. }

  function EqualsOrContains(const AParent: HTREEITEM; AChild: HTREEITEM): Boolean;
  begin
    Result := False;
    repeat
      if AChild = AParent then begin
        Result := True;
        Break;
      end;
      AChild := TreeView_GetParent(Handle, AChild);
    until AChild = nil;
  end;

var
  Item, NextItem: HTREEITEM;
  TVItem: TTVItem;
begin
  Item := TreeView_GetChild(Handle, ParentItem);
  while Assigned(Item) do begin
    { Determine the next item in advance since Item might get deleted }
    NextItem := TreeView_GetNextSibling(Handle, Item);
    TVItem.mask := TVIF_PARAM;
    TVItem.hItem := Item;
    if TreeView_GetItem(Handle, TVItem) then begin
      if PItemData(TVItem.lParam).NewItem and not EqualsOrContains(Item, ItemToKeep) then begin
        TreeView_DeleteItem(Handle, Item);
        { If there are no children left on the parent, remove its '+' sign }
        if TreeView_GetChild(Handle, ParentItem) = nil then
          SetItemHasChildren(ParentItem, False);
      end
      else
        DeleteObsoleteNewItems(Item, ItemToKeep);
    end;
    Item := NextItem;
  end;
end;

function TCustomFolderTreeView.InsertItem(const ParentItem: HTREEITEM;
  const AName, ACustomDisplayName: String;
  const ANewItem, AReadProperDisplayName: Boolean): HTREEITEM;
var
  InsertStruct: TTVInsertStruct;
  ItemData: PItemData;
begin
  if ANewItem then
    DeleteObsoleteNewItems(nil, ParentItem);
  InsertStruct.hParent := ParentItem;
  if ANewItem then
    InsertStruct.hInsertAfter := TVI_SORT
  else
    InsertStruct.hInsertAfter := TVI_LAST;
  InsertStruct.item.mask := TVIF_TEXT or TVIF_IMAGE or
    TVIF_SELECTEDIMAGE or TVIF_CHILDREN or TVIF_PARAM;
  InsertStruct.item.hItem := nil;  { not used }
  if ANewItem then begin
    InsertStruct.item.mask := InsertStruct.item.mask or TVIF_STATE;
    InsertStruct.item.stateMask := TVIS_CUT;
    InsertStruct.item.state := TVIS_CUT;
  end;
  InsertStruct.item.pszText := LPSTR_TEXTCALLBACK;
  InsertStruct.item.iImage := I_IMAGECALLBACK;
  InsertStruct.item.iSelectedImage := I_IMAGECALLBACK;
  if ANewItem then
    InsertStruct.item.cChildren := 0
  else begin
    if ParentItem = nil then
      InsertStruct.item.cChildren := 1
    else
      InsertStruct.item.cChildren := I_CHILDRENCALLBACK;
  end;
  InsertStruct.item.lParam := 0;
  New(ItemData);
  ItemData.Name := AName;
  if ACustomDisplayName = '' then
    ItemData.DisplayName := AName
  else
    ItemData.DisplayName := ACustomDisplayName;
  ItemData.NewItem := ANewItem;
  ItemData.ProperDisplayNameSet := not AReadProperDisplayName;
  ItemData.ChildrenAdded := False;
  Pointer(InsertStruct.item.lParam) := ItemData;
  Result := TreeView_InsertItem(Handle, InsertStruct);
end;

function TCustomFolderTreeView.FindItem(const ParentItem: HTREEITEM;
  const AName: String): HTREEITEM;
var
  TVItem: TTVItem;
begin
  Result := TreeView_GetChild(Handle, ParentItem);
  while Assigned(Result) do begin
    TVItem.mask := TVIF_PARAM;
    TVItem.hItem := Result;
    if TreeView_GetItem(Handle, TVItem) then
      if PathCompare(PItemData(TVItem.lParam).Name, AName) = 0 then
        Break;
    Result := TreeView_GetNextSibling(Handle, Result);
  end;
end;

function TCustomFolderTreeView.FindOrCreateItem(const ParentItem: HTREEITEM;
  const AName: String): HTREEITEM;
begin
  Result := FindItem(ParentItem, AName);
  if Result = nil then begin
    if Assigned(ParentItem) then
      SetItemHasChildren(ParentItem, True);
    Result := InsertItem(ParentItem, AName, '', True, False);
  end;
end;

function TCustomFolderTreeView.GetRootItem: HTREEITEM;
begin
  Result := nil;
end;

procedure TCustomFolderTreeView.SelectItem(const Item: HTREEITEM);

  procedure ExpandParents(Item: HTREEITEM);
  begin
    Item := TreeView_GetParent(Handle, Item);
    if Assigned(Item) then begin
      ExpandParents(Item);
      TreeView_Expand(Handle, Item, TVE_EXPAND);
    end;
  end;

begin
  { Must manually expand parents prior to calling TreeView_SelectItem;
    see top of source code for details }
  if Assigned(Item) then
    ExpandParents(Item);
  TreeView_SelectItem(Handle, Item);
end;

procedure TCustomFolderTreeView.ChangeDirectory(const Value: String;
  const CreateNewItems: Boolean);
{ Changes to the specified directory. Value must begin with a drive letter
  (e.g. "C:\directory"); relative paths and UNC paths are not allowed.
  If CreateNewItems is True, new items will be created if one or more elements
  of the path do not exist. }
var
  PStart, PEnd: PChar;
  S: String;
  ParentItem, Item: HTREEITEM;
begin
  SelectItem(nil);

  ParentItem := GetRootItem;
  PStart := PChar(Value);
  while PStart^ <> #0 do begin
    if Assigned(ParentItem) then
      TreeView_Expand(Handle, ParentItem, TVE_EXPAND);

    { Extract a single path component }
    PEnd := PStart;
    while (PEnd^ <> #0) and (PEnd^ <> '\') do
      PEnd := CharNext(PEnd);
    SetString(S, PStart, PEnd - PStart);
    if (Length(S) = 2) and (S[2] = ':') then
      S := S + '\';

    { Find that component under ParentItem }
    if CreateNewItems and Assigned(ParentItem) then
      Item := FindOrCreateItem(ParentItem, S)
    else
      Item := FindItem(ParentItem, S);
    if Item = nil then
      Break;
    ParentItem := Item;

    PStart := PEnd;
    while PStart^ = '\' do
      Inc(PStart);
  end;

  if Assigned(ParentItem) then
    SelectItem(ParentItem);
end;

procedure TCustomFolderTreeView.SetDirectory(const Value: String);
begin
  ChangeDirectory(Value, False);
end;

procedure TCustomFolderTreeView.CreateNewDirectory(const ADefaultName: String);
{ Creates a new node named AName underneath the selected node. Does nothing
  if there is no selected node. }
var
  ParentItem, Item: HTREEITEM;
  I: Integer;
  S: String;
begin
  ParentItem := TreeView_GetSelection(Handle);
  if ParentItem = nil then
    Exit;

  DeleteObsoleteNewItems(nil, ParentItem);

  { Expand and find a unique name }
  TreeView_Expand(Handle, ParentItem, TVE_EXPAND);
  I := 0;
  repeat
    Inc(I);
    if I = 1 then
      S := ADefaultName
    else
      S := ADefaultName + Format(' (%d)', [I]);
  until FindItem(ParentItem, S) = nil;

  SetItemHasChildren(ParentItem, True);
  Item := InsertItem(ParentItem, S, '', True, False);
  SelectItem(Item);

  if CanFocus then
    SetFocus;
  TreeView_EditLabel(Handle, Item);
end;

{ TFolderTreeView }

procedure TFolderTreeView.ItemChildrenNeeded(const Item: HTREEITEM);

  procedure AddDrives;
  var
    Drives: DWORD;
    Drive: Char;
  begin
    Drives := GetLogicalDrives;
    for Drive := 'A' to 'Z' do begin
      if Drives and 1 <> 0 then
        InsertItem(nil, Drive + ':\', '', False, True);
      Drives := Drives shr 1;
    end;
  end;

  procedure AddSubdirectories(const ParentItem: HTREEITEM; const Path: String);
  var
    OldErrorMode: UINT;
    H: THandle;
    FindData: TWin32FindData;
  begin
    OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
    try
      H := FindFirstFile(PChar(AddBackslash(Path) + '*'), FindData);
      if H <> INVALID_HANDLE_VALUE then begin
        try
          repeat
            if IsListableDirectory(FindData) then
              InsertItem(ParentItem, FindData.cFileName, '', False, False);
          until not FindNextFile(H, FindData);
        finally
          Windows.FindClose(H);
        end;
      end;
    finally
      SetErrorMode(OldErrorMode);
    end;
  end;

begin
  if Item = nil then
    AddDrives
  else begin
    AddSubdirectories(Item, GetItemFullPath(Item));
    { When a text callback is used, sorting after all items are inserted is
      exponentially faster than using hInsertAfter=TVI_SORT }
    TreeView_SortChildren(Handle, Item, 0);
  end;
end;

function TFolderTreeView.GetItemImageIndex(const Item: HTREEITEM;
  const NewItem, SelectedImage: Boolean): Integer;
begin
  if NewItem then
    Result := GetDefFolderImageIndex(SelectedImage)
  else
    Result := GetFileImageIndex(GetItemFullPath(Item), SelectedImage);
end;

function TFolderTreeView.ItemHasChildren(const Item: HTREEITEM): Boolean;
var
  Path: String;
  OldErrorMode: UINT;
begin
  Path := GetItemFullPath(Item);
  OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  try
    Result := (GetDriveType(PChar(AddBackslash(PathExtractDrive(Path)))) = DRIVE_REMOTE) or
      HasSubfolders(Path);
  finally
    SetErrorMode(OldErrorMode);
  end;
end;

{ TStartMenuFolderTreeView }

procedure TStartMenuFolderTreeView.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.Style := Params.Style and not TVS_LINESATROOT;
end;

function TStartMenuFolderTreeView.GetItemImageIndex(const Item: HTREEITEM;
  const NewItem, SelectedImage: Boolean): Integer;
begin
  Result := FImageIndexes[SelectedImage];
end;

function TStartMenuFolderTreeView.GetRootItem: HTREEITEM;
begin
  { The top item ('Programs') is considered the root }
  Result := TreeView_GetRoot(Handle);
end;

procedure TStartMenuFolderTreeView.ItemChildrenNeeded(const Item: HTREEITEM);

  procedure AddSubfolders(const ParentItem: HTREEITEM; const Path, StartupPath: String);
  var
    StartupName: String;
    OldErrorMode: UINT;
    H: THandle;
    FindData: TWin32FindData;
    S: String;
  begin
    { Determine the name of the Startup folder so that we can hide it from the
      list }
    if StartupPath <> '' then
      if PathCompare(AddBackslash(Path), PathExtractPath(StartupPath)) = 0 then
        StartupName := PathExtractName(StartupPath);

    OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
    try
      H := FindFirstFile(PChar(AddBackslash(Path) + '*'), FindData);
      if H <> INVALID_HANDLE_VALUE then begin
        try
          repeat
            if IsListableDirectory(FindData) then begin
              S := FindData.cFileName;
              if PathCompare(S, StartupName) <> 0 then
                if FindItem(ParentItem, S) = nil then
                  InsertItem(ParentItem, S, '', False, False);
            end;
          until not FindNextFile(H, FindData);
        finally
          Windows.FindClose(H);
        end;
      end;
    finally
      SetErrorMode(OldErrorMode);
    end;
  end;

var
  Root: String;
  NewItem: HTREEITEM;
  Path: String;
begin
  if Item = nil then begin
    Root := FUserPrograms;
    if Root = '' then begin
      { User programs folder doesn't exist for some reason? }
      Root := FCommonPrograms;
      if Root = '' then
        Exit;
    end;
    FImageIndexes[False] := GetFileImageIndex(Root, False);
    FImageIndexes[True] := FImageIndexes[False];
    NewItem := InsertItem(nil, '', PathExtractName(Root), False, False);
    TreeView_Expand(Handle, NewItem, TVE_EXPAND);
  end
  else begin
    Path := GetItemFullPath(Item);
    if FCommonPrograms <> '' then
      AddSubfolders(Item, AddBackslash(FCommonPrograms) + Path, FCommonStartup);
    if FUserPrograms <> '' then
      AddSubfolders(Item, AddBackslash(FUserPrograms) + Path, FUserStartup);
    TreeView_SortChildren(Handle, Item, 0);
  end;
end;

function TStartMenuFolderTreeView.ItemHasChildren(const Item: HTREEITEM): Boolean;
var
  Path: String;
begin
  Path := GetItemFullPath(Item);
  if (FCommonPrograms <> '') and HasSubfolders(AddBackslash(FCommonPrograms) + Path) then
    Result := True
  else if (FUserPrograms <> '') and HasSubfolders(AddBackslash(FUserPrograms) + Path) then
    Result := True
  else
    Result := False;
end;

procedure TStartMenuFolderTreeView.SetPaths(const AUserPrograms, ACommonPrograms,
  AUserStartup, ACommonStartup: String);
begin
  FUserPrograms := AUserPrograms;
  FCommonPrograms := ACommonPrograms;
  FUserStartup := AUserStartup;
  FCommonStartup := ACommonStartup;
  RecreateWnd;
end;

end.