1berry/Inno-Setup-issrc
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity
Inno-Setup-issrc/Components/FolderTreeView.pas

1141 lines
38 KiB
ObjectPascal
Raw Permalink Blame History

unit FolderTreeView;
{
Inno Setup
Copyright (C) 1997-2024 Jordan Russell
Portions by Martijn Laan
For conditions of distribution and use, see LICENSE.TXT.
TFolderTreeView component
}
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
FDestroyingHandle: Boolean;
FDirectory: String;
FItemExpanding: 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; virtual;
function InsertItem(const ParentItem: HTREEITEM; const AName, ACustomDisplayName: String;
const ANewItem: Boolean): HTREEITEM;
procedure SelectItem(const Item: HTREEITEM);
procedure SetItemHasChildren(const Item: HTREEITEM; const AHasChildren: Boolean);
procedure SetDirectory(const Value: String);
function TryExpandItem(const Item: HTREEITEM): Boolean;
procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
procedure WMCtlColorEdit(var Message: TMessage); message WM_CTLCOLOREDIT;
procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
protected
function ItemChildrenNeeded(const Item: HTREEITEM): Boolean; 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)
private
procedure RefreshDriveItem(const Item: HTREEITEM; const ANewDisplayName: String);
protected
function ItemChildrenNeeded(const Item: HTREEITEM): Boolean; override;
function ItemHasChildren(const Item: HTREEITEM): Boolean; override;
function GetItemFullPath(Item: HTREEITEM): String; override;
function GetItemImageIndex(const Item: HTREEITEM;
const NewItem, SelectedImage: Boolean): Integer; override;
published
property Anchors;
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;
function ItemChildrenNeeded(const Item: HTREEITEM): Boolean; 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 Anchors;
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:
a. TreeView_SelectItem will first set the selected item. It will then try
to expand the parent node, causing a TVN_ITEMEXPANDING message to be
sent.
b. If the TVN_ITEMEXPANDING handler calls TreeView_SortChildren, TV_SortCB
will call TV_EnsureVisible if the selected item was one of the items
affected by the sorting (which will always be the case).
c. TV_EnsureVisible will expand parent nodes if necessary. However, since
we haven't yet returned from the original TVN_ITEMEXPANDING message
handler, the parent node doesn't yet have the TVIS_EXPANDED state,
thus it thinks the node still needs expanding.
d. Another, nested TVN_ITEMEXPANDING message is sent, bringing us back to
step b.
(Reproducible on Windows 95 and 2000.)
The recursion can be seen if you comment out the ExpandParents call in
the SelectItem method, then click "New Folder" on a folder with no
children.
(Note, however, that because of the ChildrenAdded check in our
TVN_ITEMEXPANDING handler, it can only recurse once. That won't cause a
fatal stack overflow (like it did before the ChildrenAdded check was
added), but it's still wrong to allow that to happen.)
}
uses
PathFunc, ShellApi, NewUxTheme, Types;
const
SHPPFW_NONE = $00000000;
var
SHPathPrepareForWriteFunc: function(hwnd: HWND; punkEnableModless: Pointer;
pszPath: PChar; dwFlags: DWORD): HRESULT; stdcall;
const
TVM_SETEXTENDEDSTYLE = TV_FIRST + 44;
TVS_EX_DOUBLEBUFFER = $0004;
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 IsNetworkDrive(const Drive: Char): Boolean;
{ Returns True if Drive is a network drive. Unlike GetLogicalDrives and
GetDriveType, this will find the drive even if it's currently in an
unavailable/disconnected state (i.e. showing a red "X" on the drive icon
in Windows Explorer). }
var
LocalName: String;
RemoteName: array[0..MAX_PATH-1] of Char;
RemoteNameLen, ErrorCode: DWORD;
begin
LocalName := Drive + ':';
RemoteNameLen := SizeOf(RemoteName) div SizeOf(RemoteName[0]);
ErrorCode := WNetGetConnection(PChar(LocalName), RemoteName, RemoteNameLen);
Result := (ErrorCode = NO_ERROR) or (ErrorCode = ERROR_CONNECTION_UNAVAIL);
end;
function MoveAppWindowToActiveWindowMonitor(var OldRect: TRect): Boolean;
{ This moves the application window (Application.Handle) to the same monitor
as the active window, so that a subsequent Windows dialog will display on
the same monitor. Based on code from D4+'s TApplication.MessageBox.
NOTE: This function was copied from CmnFunc.pas. }
type
HMONITOR = type THandle;
TMonitorInfo = record
cbSize: DWORD;
rcMonitor: TRect;
rcWork: TRect;
dwFlags: DWORD;
end;
const
MONITOR_DEFAULTTONEAREST = $00000002;
var
ActiveWindow: HWND;
Module: HMODULE;
MonitorFromWindow: function(hwnd: HWND; dwFlags: DWORD): HMONITOR; stdcall;
GetMonitorInfo: function(hMonitor: HMONITOR; var lpmi: TMonitorInfo): BOOL; stdcall;
MBMonitor, AppMonitor: HMONITOR;
Info: TMonitorInfo;
begin
Result := False;
ActiveWindow := GetActiveWindow;
if ActiveWindow = 0 then Exit;
Module := GetModuleHandle(user32);
MonitorFromWindow := GetProcAddress(Module, 'MonitorFromWindow');
GetMonitorInfo := GetProcAddress(Module, 'GetMonitorInfoA');
if Assigned(MonitorFromWindow) and Assigned(GetMonitorInfo) then begin
MBMonitor := MonitorFromWindow(ActiveWindow, MONITOR_DEFAULTTONEAREST);
AppMonitor := MonitorFromWindow(Application.Handle, MONITOR_DEFAULTTONEAREST);
if MBMonitor <> AppMonitor then begin
Info.cbSize := SizeOf(Info);
if GetMonitorInfo(MBMonitor, Info) then begin
GetWindowRect(Application.Handle, OldRect);
SetWindowPos(Application.Handle, 0,
Info.rcMonitor.Left + ((Info.rcMonitor.Right - Info.rcMonitor.Left) div 2),
Info.rcMonitor.Top + ((Info.rcMonitor.Bottom - Info.rcMonitor.Top) div 2),
0, 0, SWP_NOACTIVATE or SWP_NOREDRAW or SWP_NOSIZE or SWP_NOZORDER);
Result := True;
end;
end;
end;
end;
procedure MoveAppWindowBack(const OldRect: TRect);
{ Moves the application window back to its previous position after a
successful call to MoveAppWindowToActiveWindowMonitor }
begin
SetWindowPos(Application.Handle, 0,
OldRect.Left + ((OldRect.Right - OldRect.Left) div 2),
OldRect.Top + ((OldRect.Bottom - OldRect.Top) div 2),
0, 0, SWP_NOACTIVATE or SWP_NOREDRAW or SWP_NOSIZE or SWP_NOZORDER);
end;
function EnsurePathIsAccessible(const Path: String): Boolean;
{ Calls SHPathPrepareForWrite which ensures the specified path is accessible by
reconnecting network drives (important) and prompting for media on removable
drives (not so important for our purposes). (Note that despite its name,
the function does not test for write access.) }
var
ActiveWindow: HWND;
DidMove: Boolean;
OldRect: TRect;
WindowList: Pointer;
begin
{ SHPathPrepareForWrite only exists on Windows 2000, Me, and later.
Do nothing on older versions of Windows. }
if @SHPathPrepareForWriteFunc = nil then begin
Result := True;
Exit;
end;
{ Note: The SHPathPrepareForWrite documentation claims that "user interface
windows will not be created" when hwnd is NULL, however I found that on
Windows 2000, it would still display message boxes for network errors.
(To reproduce: Disable your Local Area Connection and try expanding a
network drive.) So to avoid bugs from having unowned message boxes floating
around, go ahead and pass a proper owner window. }
ActiveWindow := GetActiveWindow;
DidMove := MoveAppWindowToActiveWindowMonitor(OldRect);
WindowList := DisableTaskWindows(0);
try
Result := SUCCEEDED(SHPathPrepareForWriteFunc(Application.Handle, nil,
PChar(Path), SHPPFW_NONE));
finally
if DidMove then
MoveAppWindowBack(OldRect);
EnableTaskWindows(WindowList);
SetActiveWindow(ActiveWindow);
end;
end;
{ TCustomFolderTreeView }
type
PItemData = ^TItemData;
TItemData = record
Name: String;
NewItem: Boolean;
ChildrenAdded: Boolean;
end;
constructor TCustomFolderTreeView.Create(AOwner: TComponent);
var
LogFont: TLogFont;
begin
inherited;
ControlStyle := ControlStyle - [csCaptureMouse];
Width := 121;
Height := 97;
ParentColor := False;
TabStop := True;
if SystemParametersInfo(SPI_GETICONTITLELOGFONT, SizeOf(LogFont), @LogFont, 0) then
Font.Handle := CreateFontIndirect(LogFont);
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;
Style := Style or TVS_TRACKSELECT;
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;
SaveCursor: HCURSOR;
begin
FDestroyingHandle := False;
inherited;
FDirectory := '';
if csDesigning in ComponentState then
Exit;
{ Enable the new Explorer-style look }
if Assigned(SetWindowTheme) then begin
SetWindowTheme(Handle, 'Explorer', nil);
{ Like Explorer, enable double buffering to avoid flicker when the mouse
is moved across the items }
SendMessage(Handle, TVM_SETEXTENDEDSTYLE, TVS_EX_DOUBLEBUFFER,
TVS_EX_DOUBLEBUFFER);
end;
{ Initialize the image list }
ImageList := SHGetFileInfo('', 0, FileInfo, SizeOf(FileInfo),
SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
TreeView_SetImageList(Handle, ImageList, TVSIL_NORMAL);
{ Add the root items }
SaveCursor := SetCursor(LoadCursor(0, IDC_WAIT));
try
ItemChildrenNeeded(nil);
finally
SetCursor(SaveCursor);
end;
end;
procedure TCustomFolderTreeView.WMDestroy(var Message: TWMDestroy);
begin
{ Work around bug in pre-v6 COMCTL32: If we have the TVS_SINGLEEXPAND style
and there is a selected item when the window is destroyed, we end up
getting a bunch of TVN_SINGLEEXPAND messages because it keeps moving the
selection as it's destroying items, resulting in a stream of "Please
insert a disk in drive X:" message boxes as the selection moves across
removable drives.
Currently, however, this problem isn't seen in practice because we don't
use TVS_SINGLEEXPAND on pre-XP Windows. }
FDestroyingHandle := True; { disables our TVN_SELCHANGED handling }
SelectItem(nil);
inherited;
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.CNKeyDown(var Message: TWMKeyDown);
var
FocusWnd: HWND;
begin
{ On Delphi 5+, if a non-VCL control is focused, TApplication.IsKeyMsg will
send the CN_KEYDOWN message to the nearest VCL control. This means that
when the edit control is focused, the tree view itself gets CN_KEYDOWN
messages. Don't let the VCL handle Enter and Escape; if we're on a dialog,
those keys will close the window. }
FocusWnd := GetFocus;
if (FocusWnd <> 0) and (TreeView_GetEditControl(Handle) = FocusWnd) then
if (Message.CharCode = VK_RETURN) or (Message.CharCode = VK_ESCAPE) then
Exit;
inherited;
end;
procedure TCustomFolderTreeView.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
{ For TVS_EX_DOUBLEBUFFER to be truly flicker-free, we must use
comctl32's default WM_ERASEBKGND handling, not the VCL's (which calls
FillRect). }
DefaultHandler(Message);
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 if TreeView_GetSelection(Handle) <> Item then
SelectItem(Item);
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
{ Sanity check: Make sure this message isn't sent recursively.
(See top of source code for details.) }
if FItemExpanding then
raise Exception.Create('Internal error: Item already expanding');
FItemExpanding := True;
try
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
if ItemChildrenNeeded(Hdr.itemNew.hItem) then begin
{ 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);
end
else begin
{ A result of False means no children were added due to a
temporary error and that it should try again next time }
PItemData(Hdr.itemNew.lParam).ChildrenAdded := False;
{ Return 1 to cancel the expansion process (although it seems
to do that anyway when it sees no children were added) }
Message.Result := 1;
end;
finally
SetCursor(SaveCursor);
end;
end;
finally
FItemExpanding := False;
end;
end;
TVN_GETDISPINFO:
begin
DispItem := @PTVDispInfo(Message.NMHdr).item;
if DispItem.mask and TVIF_IMAGE <> 0 then begin
DispItem.iImage := GetItemImageIndex(DispItem.hItem,
PItemData(DispItem.lParam).NewItem, False);
end;
if DispItem.mask and TVIF_SELECTEDIMAGE <> 0 then begin
DispItem.iSelectedImage := GetItemImageIndex(DispItem.hItem,
PItemData(DispItem.lParam).NewItem, True);
end;
if DispItem.mask and TVIF_CHILDREN <> 0 then begin
DispItem.cChildren := Ord(Assigned(TreeView_GetChild(Handle, DispItem.hItem)));
if (DispItem.cChildren = 0) and not PItemData(DispItem.lParam).NewItem then
DispItem.cChildren := Ord(ItemHasChildren(DispItem.hItem));
end;
{ Store the values with the item so the callback isn't called again }
DispItem.mask := DispItem.mask or TVIF_DI_SETITEM;
end;
TVN_SELCHANGED:
begin
if not FDestroyingHandle then
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;
{ Instead of returning 1 to let the tree view update the text,
set the text ourself. This will downconvert any Unicode
characters to ANSI (if we're compiled as an ANSI app). }
TVItem.mask := TVIF_TEXT;
TVItem.hItem := DispItem.hItem;
TVItem.pszText := PChar(S);
TreeView_SetItem(Handle, TVItem);
TreeView_SortChildren(Handle, TreeView_GetParent(Handle, DispItem.hItem), False);
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;
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: 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;
{ Note: There's no performance advantage in using a callback for the text.
During a TreeView_InsertItem call, the tree view will try to read the
new item's text in order to update the horizontal scroll bar range.
(It doesn't wait until the item is painted.)
In addition, the caller may sort newly-inserted subitems, which obviously
requires reading their text. }
if ACustomDisplayName = '' then
InsertStruct.item.pszText := PChar(AName)
else
InsertStruct.item.pszText := PChar(ACustomDisplayName);
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;
ItemData.NewItem := ANewItem;
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);
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;
function TCustomFolderTreeView.TryExpandItem(const Item: HTREEITEM): Boolean;
{ Tries to expand the specified item. Returns True if the item's children were
initialized (if any), or False if the initialization failed due to a
temporary error (i.e. ItemChildrenNeeded returned False). }
var
TVItem: TTVItem;
begin
TreeView_Expand(Handle, Item, TVE_EXPAND);
TVItem.mask := TVIF_CHILDREN or TVIF_PARAM;
TVItem.hItem := Item;
Result := TreeView_GetItem(Handle, TVItem) and
(PItemData(TVItem.lParam).ChildrenAdded or (TVItem.cChildren = 0));
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
if not TryExpandItem(ParentItem) then
Break;
{ Extract a single path component }
PEnd := PStart;
while (PEnd^ <> #0) and not PathCharIsSlash(PEnd^) do
PEnd := PathStrNextChar(PEnd);
SetString(S, PStart, PEnd - PStart);
{ 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 PathCharIsSlash(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 }
if not TryExpandItem(ParentItem) then
Exit;
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);
SelectItem(Item);
if CanFocus then
SetFocus;
TreeView_EditLabel(Handle, Item);
end;
{ TFolderTreeView }
function TFolderTreeView.ItemChildrenNeeded(const Item: HTREEITEM): Boolean;
procedure AddDrives;
var
Drives: DWORD;
Drive: Char;
begin
Drives := GetLogicalDrives;
for Drive := 'A' to 'Z' do begin
if (Drives and 1 <> 0) or IsNetworkDrive(Drive) then
InsertItem(nil, Drive + ':', GetFileDisplayName(Drive + ':\'), False);
Drives := Drives shr 1;
end;
end;
function AddSubdirectories(const ParentItem: HTREEITEM;
const Path: String): Boolean;
var
OldErrorMode: UINT;
H: THandle;
FindData: TWin32FindData;
S: String;
begin
OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
{ The path might be on a disconnected network drive. Ensure it's
connected before attempting to enumerate subdirectories. }
if Length(Path) = 3 then begin { ...only do this on the root }
if not EnsurePathIsAccessible(Path) then begin
Result := False;
Exit;
end;
{ Refresh the icon and text in case the drive was indeed reconnected }
RefreshDriveItem(ParentItem, GetFileDisplayName(Path));
end;
Result := True;
H := FindFirstFile(PChar(AddBackslash(Path) + '*'), FindData);
if H <> INVALID_HANDLE_VALUE then begin
try
repeat
if IsListableDirectory(FindData) then begin
S := FindData.cFileName;
InsertItem(ParentItem, S, GetFileDisplayName(AddBackslash(Path) + S),
False);
end;
until not FindNextFile(H, FindData);
finally
Windows.FindClose(H);
end;
end;
finally
SetErrorMode(OldErrorMode);
end;
end;
begin
if Item = nil then begin
AddDrives;
Result := True;
end
else begin
Result := AddSubdirectories(Item, GetItemFullPath(Item));
if Result then begin
{ When a text callback is used, sorting after all items are inserted is
exponentially faster than using hInsertAfter=TVI_SORT }
TreeView_SortChildren(Handle, Item, False);
end;
end;
end;
function TFolderTreeView.GetItemFullPath(Item: HTREEITEM): String;
begin
Result := inherited GetItemFullPath(Item);
if (Length(Result) = 2) and (Result[2] = ':') then
Result := Result + '\';
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;
procedure TFolderTreeView.RefreshDriveItem(const Item: HTREEITEM;
const ANewDisplayName: String);
var
TVItem: TTVItem;
begin
TVItem.mask := TVIF_IMAGE or TVIF_SELECTEDIMAGE;
TVItem.hItem := Item;
TVItem.iImage := I_IMAGECALLBACK;
TVItem.iSelectedImage := I_IMAGECALLBACK;
if ANewDisplayName <> '' then begin
TVItem.mask := TVItem.mask or TVIF_TEXT;
TVItem.pszText := PChar(ANewDisplayName);
end;
TreeView_SetItem(Handle, TVItem);
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;
function TStartMenuFolderTreeView.ItemChildrenNeeded(const Item: HTREEITEM): Boolean;
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, GetFileDisplayName(AddBackslash(Path) + S), False);
end;
until not FindNextFile(H, FindData);
finally
Windows.FindClose(H);
end;
end;
finally
SetErrorMode(OldErrorMode);
end;
end;
var
Root, S: String;
NewItem: HTREEITEM;
Path: String;
begin
Result := True;
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];
S := GetFileDisplayName(Root);
if S = '' then
S := PathExtractName(Root);
NewItem := InsertItem(nil, '', S, 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, False);
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;
function GetSystemDir: String;
var
Buf: array[0..MAX_PATH-1] of Char;
begin
GetSystemDirectory(Buf, SizeOf(Buf) div SizeOf(Buf[0]));
Result := StrPas(Buf);
end;
initialization
InitThemeLibrary;
SHPathPrepareForWriteFunc := GetProcAddress(LoadLibrary(PChar(AddBackslash(GetSystemDir) + shell32)),
'SHPathPrepareForWriteW');
end.
Reference in New Issue View Git Blame Copy Permalink