9
940801
Unregistered / Unconfirmed
GUEST, unregistred user!
//********************************************************
//
// GFavoritesTree
// By 940801,l940801@yahoo.com
//
//********************************************************
unit GFavoritesTrees;
interface
uses
Windows, Messages, Classes, Forms, SysUtils, ComCtrls, Commctrl, ShellAPI, IniFiles,
Registry, Controls, SHDocVw, ComObj;
type
TGFavoriteType = (gftFolder, gftUrl, gftUnknown);
TGFavorite = Class
private
FParent: TGFavorite;
FFavoriteType: TGFavoriteType;
FFileName: string;
FDisplayName: string;
FCanDelete: Boolean;
FCanRename: Boolean;
FUrl: string;
function GetPath: string;
function GetFullFileName: string;
function GetUrl: string;
procedure SetUrl(Value: string);
protected
public
constructor Create(APathName: string); overload;
constructor Create(AParent: TGFavorite; FindFileData: TSearchRec); overload;
destructor Destroy; override;
function ComparePos(GFavorite1, GFavorite2: TGFavorite): SmallInt;
function Rename(const NewName: string): Boolean;
function Delete: Boolean;
procedure ShowProperty;
property Url: string read FUrl write SetUrl;
property FileName: string read FFileName;
property FullFileName: string read GetFullFileName;
property Path: string read GetPath;
property DisplayName: string read FDisplayName;
property Parent: TGFavorite read FParent;
property FavoriteType: TGFavoriteType read FFavoriteType;
property CanDelete: Boolean read FCanDelete;
property CanRename: Boolean read FCanRename;
end;
TAddFavoriteEvent = procedure(Sender: TObject; AFavorite: TGFavorite;
var CanAdd: Boolean) of object;
TUrlClickEvent = procedure (Sender: TObject; Url: string) of object;
TCustomGFavoritesTree = Class(TCustomTreeView)
private
FUpdating, FLoadingRoot: Boolean;
FRootCaption: string;
FOnAddFavorite: TAddFavoriteEvent;
FOnUrlClick: TUrlClickEvent;
FShowUrlHint: Boolean;
FCanImportExport: Boolean;
function GetFavorites(Index: integer): TGFavorite;
procedure SetRootCaption(Value: string);
procedure CreateRoot;
function GetShellImage(FileName: string; Open: Boolean): Integer;
function GetSelectedFavorite: TGFavorite;
function GetIEVersion: Extended;
procedure SetShowUrlHint(Value: Boolean);
protected
procedure Loaded; override;
procedure DBLClick; override;
procedure Delete(Node: TTreeNode); override;
procedure Edit(const Item: TTVItem); override;
procedure ClearItems;
procedure InitNode(NewNode: TTreeNode; ParentNode: TTreeNode; FindFileData: TSearchRec);
procedure PopulateNode(Node: TTreeNode);
function CanExpand(Node: TTreeNode): Boolean; override;
procedure WndProc(var Msg: TMessage); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure RefreshRoot;
procedure DeleteNode(Node: TTreeNode);
procedure EditNode(Node: TTreeNode);
procedure OrganizeFavorites;
procedure ExportFavorites;
procedure ImportFavorites;
property Favorites[Index: Integer]: TGFavorite read GetFavorites; default;
property RootCaption: string read FRootCaption write SetRootCaption;
property SelectedFavorite: TGFavorite read GetSelectedFavorite;
property ShowUrlHint: Boolean read FShowUrlHint write SetShowUrlHint;
property OnUrlClick: TUrlClickEvent read FOnUrlClick write FOnUrlClick;
property OnAddFavorite: TAddFavoriteEvent read FOnAddFavorite write FOnAddFavorite;
property CanImportExport: Boolean read FCanImportExport write FCanImportExport;
end;
TGFavoritesTree = Class(TCustomGFavoritesTree)
published
property RootCaption;
property SelectedFavorite;
property OnUrlClick;
property OnAddFavorite;
property ShowUrlHint;
property CanImportExport;
property Align;
property Anchors;
property AutoExpand;
property BiDiMode;
property BorderStyle;
property BorderWidth;
property ChangeDelay;
property Color;
property Ctl3D;
property Constraints;
property DragKind;
property DragCursor;
property DragMode;
property Enabled;
property Font;
// property HideSelection;
// property HotTrack;
// property Images;
property Indent;
property ParentBiDiMode;
property ParentColor default False;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly;
// property RightClickSelect;
// property RowSelect;
// property ShowButtons;
property ShowHint;
// property ShowLines;
// property ShowRoot;
// property SortType;
// property StateImages;
property TabOrder;
property TabStop default True;
// property ToolTips;
property Visible;
property OnAdvancedCustomDraw;
property OnAdvancedCustomDrawItem;
property OnChange;
property OnChanging;
property OnClick;
property OnCollapsed;
property OnCollapsing;
property OnCompare;
property OnContextPopup;
property OnCustomDraw;
property OnCustomDrawItem;
property OnDblClick;
property OnDeletion;
property OnDragDrop;
property OnDragOver;
property OnEdited;
property OnEditing;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnExpanding;
property OnExpanded;
// property OnGetImageIndex;
// property OnGetSelectedIndex;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
property Items;
end;
procedure Register;
const
CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}';
implementation
procedure Register;
begin
RegisterComponents('Grape', [TGFavoritesTree]);
end;
{ TGFavoritesTreeNode }
constructor TGFavorite.Create(APathName: string);
begin
inherited Create;
FParent:= nil;
FFileName:= ExtractFileName(APathName);
FDisplayName:= ExtractFilePath(APathName);
FDisplayName:= Copy(FDisplayname, 1, Length(FDisplayName) - 1);
FCanDelete:= False;
FCanRename:= False;
if DirectoryExists(APathName) then
FFavoriteType:= gftFolder
else
FFavoriteType:= gftUnknown;
end;
constructor TGFavorite.Create(AParent: TGFavorite; FindFileData: TSearchRec);
begin
inherited Create;
FParent:= AParent;
FDisplayName:= ChangeFileExt(FindFileData.Name, '');
FCanDelete:= True;
FCanRename:= True;
if FindFileData.Attr = faDirectory then
FFavoriteType:= gftFolder
else
FFavoriteType:= gftUnknown;
FFileName:= FindFileData.FindData.cAlternateFileName;
if FFileName = '' then FFileName:= FindFileData.Name;
if (FFavoriteType = gftUnknown) and SameText(ExtractFileExt(FFileName), '.url') then
begin
FUrl:= GetUrl;
if FUrl <> '' then
FFavoriteType:= gftUrl
end;
end;
destructor TGFavorite.Destroy;
begin
inherited;
end;
function TGFavorite.GetPath: string;
begin
if FParent <> nil then
Result:= FParent.FullFileName
else
Result:= FDisplayName;
end;
function TGFavorite.GetFullFileName: string;
begin
Result:= Path + '/' + FFileName;
end;
function TGFavorite.GetUrl: string;
begin
Result:= '';
with TIniFile.Create(FullFileName) do
try
Result:= ReadString('InternetShortcut', 'URL', '');
finally
Free;
end;
end;
procedure TGFavorite.SetUrl(Value: string);
begin
FUrl:= Value;
with TIniFile.Create(FullFileName) do
try
WriteString('InternetShortcut', 'URL', Value);
finally
Free;
end;
end;
function TGFavorite.ComparePos(GFavorite1, GFavorite2: TGFavorite): SmallInt;
begin
if GFavorite1.FavoriteType = GFavorite2.FavoriteType then
Result:= CompareText(GFavorite1.FileName, GFavorite2.FileName)
else if GFavorite1.FavoriteType = gftFolder then
Result:= -1
else
Result:= 1;
end;
function TGFavorite.Rename(const NewName: string): boolean;
var
lpFileOp: TSHFileOpStruct;
pOldName: Array [0..MAX_PATH + 1] of Char;
pNewName: Array [0..MAX_PATH + 1] of Char;
TempStr: string;
begin
TempStr:= FullFileName;
FillChar(pOldName, MAX_PATH + 1, #0);
StrPCopy(pOldName, TempStr);
TempStr:= GetPath + '/' + NewName;
if (FavoriteType = gftUrl) and not SameText(ExtractFileExt(TempStr), '.url') then
TempStr:= TempStr + '.url';
FillChar(pNewName, MAX_PATH + 1, #0);
StrPCopy(pNewName, TempStr);
with lpFileOp do
begin
Wnd:= Application.Handle;
wFunc:= FO_RENAME;
pFrom:= pOldName;
pTo:= pNewName;
fFlags:= FOF_ALLOWUNDO + FOF_RENAMEONCOLLISION;
end;
Result:= SHFileOperation(lpFileOp) = 0;
if Result then FFileName:= NewName;
end;
function TGFavorite.Delete: Boolean;
var
lpFileOp: TSHFileOpStruct;
pFileName: Array [0..MAX_PATH + 1] of Char;
TempStr: string;
begin
TempStr:= FullFileName;
FillChar(pFileName, MAX_PATH + 1, #0);
StrPCopy(pFileName, TempStr);
with lpFileOp do
begin
Wnd:= Application.Handle;
wFunc:= FO_DELETE;
pFrom:= pFileName;
pTo:= nil;
fFlags:= FOF_ALLOWUNDO + FOF_SILENT + FOF_NOCONFIRMATION;
end;
Result:= (SHFileOperation(lpFileOp) = 0) and not lpFileOp.fAnyOperationsAborted;
end;
procedure TGFavorite.ShowProperty;
begin
end;
{ TCustomGFavoritesTree }
constructor TCustomGFavoritesTree.Create(AOwner: TComponent);
begin
inherited;
HotTrack:= True;
RowSelect:= True;
ToolTips:= True;
ShowLines:= False;
ShowButtons:= False;
ShowRoot:= False;
RightClickSelect:= True;
HideSelection:= False;
FRootCaption:= 'Favorites';
FUpdating:= False;
FLoadingRoot:= False;
FShowUrlHint:= True;
ShowHint:= True;
FCanImportExport:= GetIEVersion > 5.0;
end;
destructor TCustomGFavoritesTree.Destroy;
begin
ClearItems;
inherited;
end;
procedure TCustomGFavoritesTree.ClearItems;
var
I: Integer;
begin
for I:= 0 to Items.Count - 1 do
begin
if Items.Data <> nil then
TGFavorite(Items.Data).Free;
Items.Data:= nil;
end;
Items.Clear;
end;
procedure TCustomGFavoritesTree.Loaded;
var
FileInfo: TSHFileInfo;
TempImages: Integer;
begin
inherited Loaded;
if (csDesigning in ComponentState) then Exit;
TempImages:= SHGetFileInfo('C:/',
0, FileInfo, SizeOf(FileInfo), SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
SendMessage(Handle, TVM_SETIMAGELIST, TVSIL_NORMAL, TempImages);
CreateRoot;
end;
function TreeSortFunc(Node1, Node2: TTreeNode; lParam: Integer): Integer; stdcall;
begin
Result:= TGFavorite(Node1.Data).Parent.ComparePos(TGFavorite(Node1.Data), TGFavorite(Node2.Data));
end;
procedure TCustomGFavoritesTree.InitNode(NewNode: TTreeNode; ParentNode: TTreeNode; FindFileData: TSearchRec);
var
CanAdd: Boolean;
begin
NewNode.Data:= TGFavorite.Create(TGFavorite(ParentNode.Data), FindFileData);
with TGFavorite(NewNode.Data) do
begin
if FavoriteType = gftUnknown then
NewNode.Delete
else
begin
NewNode.Text:= DisplayName;
NewNode.ImageIndex:= GetShellImage(FullFileName, False);
NewNode.SelectedIndex:= GetShellImage(FullFileName, True);
if NewNode.SelectedIndex = 0 then NewNode.SelectedIndex:= NewNode.ImageIndex;
if FavoriteType = gftFolder then NewNode.HasChildren:= True
else NewNode.HasChildren:= False;
end;
end;
CanAdd:= True;
if Assigned(FOnAddFavorite) then FOnAddFavorite(Self, TGFavorite(NewNode.Data), CanAdd);
if not CanAdd then NewNode.Delete;
end;
procedure TCustomGFavoritesTree.PopulateNode(Node: TTreeNode);
var
NewNode: TTreeNode;
SaveCursor: TCursor;
SR : TSearchRec;
Found: Integer;
begin
if TGFavorite(Node.Data^).FavoriteType <> gftFolder then Exit;
SaveCursor:= Screen.Cursor;
Screen.Cursor:= crHourglass;
Items.BeginUpdate;
try
Found:= FindFirst(TGFavorite(Node.Data).FullFileName + '/*.*', faDirectory + faArchive, SR);
while Found = 0 do
begin
if (SR.Name <> '.') and (SR.Name <> '..') then
begin
NewNode:= Items.AddChild(Node, '');
InitNode(NewNode, Node, SR);
end;
Found:= FindNext(SR);
end;
FindClose(SR);
Node.CustomSort(@TreeSortFunc, 0);
finally
Items.EndUpdate;
Screen.Cursor:= SaveCursor;
end;
end;
procedure TCustomGFavoritesTree.CreateRoot;
var
FavoritesParh: string;
Buf: Array [0..MAX_PATH] of Char;
RootNode: TTreeNode;
begin
with TRegistry.Create do
try
RootKey:= HKEY_CURRENT_USER;
if OpenKey('/Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders', False) then
begin
FavoritesParh:= ReadString('Favorites');
ExpandEnvironmentStrings(PChar(FavoritesParh), Buf, MAX_PATH);
FavoritesParh:= Buf;
end;
finally
Free;
end;
Items.BeginUpdate;
try
if Items.Count > 0 then
ClearItems;
RootNode:= Items.Add(nil, '');
with RootNode do
begin
Data:= TGFavorite.Create(FavoritesParh);
Text:= FRootCaption;
RootNode.ImageIndex:= GetShellImage(FavoritesParh, False);
RootNode.SelectedIndex:= GetShellImage(FavoritesParh, True);
RootNode.HasChildren:= True;
end;
RootNode.Expand(False);
Selected:= RootNode;
finally
Items.EndUpdate;
end;
end;
function TCustomGFavoritesTree.CanExpand(Node: TTreeNode): Boolean;
begin
Result:= True;
if (csDesigning in ComponentState) and (Node.Level > 0) then Exit;
if Assigned(OnExpanding) then OnExpanding(Self, Node, Result);
if Result and (TGFavorite(Node.Data).FavoriteType = gftFolder) and (Node.Count = 0) then
PopulateNode(Node);
Node.HasChildren:= Node.Count > 0;
end;
procedure TCustomGFavoritesTree.Edit(const Item: TTVItem);
var
S: string;
Node: TTreeNode;
begin
with Item do
if pszText <> nil then
begin
S:= pszText;
Node:= Items.GetNode(Item.hItem);
if Assigned(OnEdited) then OnEdited(Self, Node, S);
if Node <> nil then
if Node.AbsoluteIndex = 0 then
SetRootCaption(S)
else
if TGFavorite(Node.Data).Rename(S) then Node.Text:= S
end;
end;
procedure TCustomGFavoritesTree.Delete(Node: TTreeNode);
begin
if Assigned(Node.Data) then
begin
TGFavorite(Node.Data).Free;
Node.Data:= nil;
end;
inherited Delete(Node);
end;
function TCustomGFavoritesTree.GetFavorites(Index: integer): TGFavorite;
begin
Result:= TGFavorite(Items[Index].Data);
end;
function TCustomGFavoritesTree.GetSelectedFavorite: TGFavorite;
begin
Result:= nil;
if Selected <> nil then
Result:= TGFavorite(Selected.Data)
end;
function TCustomGFavoritesTree.GetShellImage(FileName: string; Open: Boolean): Integer;
var
FileInfo: TSHFileInfo;
Flags: Integer;
begin
Flags:= SHGFI_SYSICONINDEX;
if Open then Flags:= Flags or SHGFI_OPENICON
else Flags:= Flags or SHGFI_SMALLICON;
SHGetFileInfo(PChar(FileName),
0,
FileInfo,
SizeOf(FileInfo),
Flags);
Result:= FileInfo.iIcon;
end;
procedure TCustomGFavoritesTree.SetRootCaption(Value: string);
begin
FRootCaption:= Value;
if TopItem <> nil then
TopItem.Text:= Value;
end;
procedure TCustomGFavoritesTree.DBLClick;
begin
inherited;
if Assigned(FOnUrlClick) and (SelectedFavorite <> nil)
and (SelectedFavorite.FavoriteType = gftUrl) then
begin
FOnUrlClick(Self, SelectedFavorite.Url);
end;
end;
procedure TCustomGFavoritesTree.RefreshRoot;
begin
if FUpdating then Exit;
FUpdating:= True;
try
CreateRoot;
finally
FUpdating:= False;
end;
end;
procedure TCustomGFavoritesTree.WndProc(var Msg: TMessage);
var
Node: TTreeNode;
begin
inherited;
case Msg.Msg of
WM_RBUTTONDOWN:
begin
if not(csDesigning in ComponentState) then
begin
Node:= GetNodeAt(LOWORD(Msg.lParam), HIWORD(Msg.LParam));
if Node <> nil then Node.Selected:= true;
end;
end;
WM_MOUSEMOVE:
begin
if FShowUrlHint then
begin
Node:= GetNodeAt(LOWORD(Msg.lParam), HIWORD(Msg.lParam));
if (Node <> nil) and (Node.Data <> nil) then Hint:= TGFavorite(Node.Data).Url;
end;
end;
end;
end;
procedure TCustomGFavoritesTree.DeleteNode(Node: TTreeNode);
begin
if (Node = nil) or (Node.Data = nil) or not TGFavorite(Node.Data).CanDelete then exit;
if TGFavorite(Node.Data).Delete then
Node.Delete;
end;
procedure TCustomGFavoritesTree.EditNode(Node: TTreeNode);
begin
if (Node = nil) or (Node.Data = nil) then exit;
Node.Selected:= True;
Node.EditText;
end;
procedure TCustomGFavoritesTree.OrganizeFavorites;
var
H: HWnd;
p: procedure(Handle: THandle; Path: PChar); stdcall;
begin
H:= LoadLibrary(PChar('shdocvw.dll'));
if H <> 0 then begin
p:= GetProcAddress(H, PChar('DoOrganizeFavDlg'));
if Assigned(p) then p(Application.Handle, PChar(Favorites[0].FullFileName));
end;
FreeLibrary(h);
RefreshRoot;
end;
procedure TCustomGFavoritesTree.ExportFavorites;
var
Sh: ISHellUIHelper;
begin
Sh:= CreateComObject(CLSID_SHELLUIHELPER) as ISHELLUIHELPER;
sh.ImportExportFavorites(FALSE, '');
end;
procedure TCustomGFavoritesTree.ImportFavorites;
var
Sh: ISHellUIHelper;
begin
Sh:= CreateComObject(CLSID_SHELLUIHELPER) as ISHELLUIHELPER;
sh.ImportExportFavorites(TRUE, '');
RefreshRoot;
end;
function TCustomGFavoritesTree.GetIEVersion: Extended;
var
Reg: TRegistry;
S: string;
Code: integer;
begin
Reg:= TRegistry.Create;
with Reg do begin
RootKey:= HKEY_LOCAL_MACHINE;
OpenKey('Software/Microsoft/Internet Explorer', False);
if ValueExists('Version') then S:= ReadString('Version')
else S:= '0';
CloseKey;
Free;
end;
Val(System.Copy(S, 1, 3), Result, Code);
if Code <> 0 then Result:= 1.0;
end;
procedure TCustomGFavoritesTree.SetShowUrlHint(Value: Boolean);
begin
FShowUrlHint:= Value;
if Value then ShowHint:= True;
end;
end.
//
// GFavoritesTree
// By 940801,l940801@yahoo.com
//
//********************************************************
unit GFavoritesTrees;
interface
uses
Windows, Messages, Classes, Forms, SysUtils, ComCtrls, Commctrl, ShellAPI, IniFiles,
Registry, Controls, SHDocVw, ComObj;
type
TGFavoriteType = (gftFolder, gftUrl, gftUnknown);
TGFavorite = Class
private
FParent: TGFavorite;
FFavoriteType: TGFavoriteType;
FFileName: string;
FDisplayName: string;
FCanDelete: Boolean;
FCanRename: Boolean;
FUrl: string;
function GetPath: string;
function GetFullFileName: string;
function GetUrl: string;
procedure SetUrl(Value: string);
protected
public
constructor Create(APathName: string); overload;
constructor Create(AParent: TGFavorite; FindFileData: TSearchRec); overload;
destructor Destroy; override;
function ComparePos(GFavorite1, GFavorite2: TGFavorite): SmallInt;
function Rename(const NewName: string): Boolean;
function Delete: Boolean;
procedure ShowProperty;
property Url: string read FUrl write SetUrl;
property FileName: string read FFileName;
property FullFileName: string read GetFullFileName;
property Path: string read GetPath;
property DisplayName: string read FDisplayName;
property Parent: TGFavorite read FParent;
property FavoriteType: TGFavoriteType read FFavoriteType;
property CanDelete: Boolean read FCanDelete;
property CanRename: Boolean read FCanRename;
end;
TAddFavoriteEvent = procedure(Sender: TObject; AFavorite: TGFavorite;
var CanAdd: Boolean) of object;
TUrlClickEvent = procedure (Sender: TObject; Url: string) of object;
TCustomGFavoritesTree = Class(TCustomTreeView)
private
FUpdating, FLoadingRoot: Boolean;
FRootCaption: string;
FOnAddFavorite: TAddFavoriteEvent;
FOnUrlClick: TUrlClickEvent;
FShowUrlHint: Boolean;
FCanImportExport: Boolean;
function GetFavorites(Index: integer): TGFavorite;
procedure SetRootCaption(Value: string);
procedure CreateRoot;
function GetShellImage(FileName: string; Open: Boolean): Integer;
function GetSelectedFavorite: TGFavorite;
function GetIEVersion: Extended;
procedure SetShowUrlHint(Value: Boolean);
protected
procedure Loaded; override;
procedure DBLClick; override;
procedure Delete(Node: TTreeNode); override;
procedure Edit(const Item: TTVItem); override;
procedure ClearItems;
procedure InitNode(NewNode: TTreeNode; ParentNode: TTreeNode; FindFileData: TSearchRec);
procedure PopulateNode(Node: TTreeNode);
function CanExpand(Node: TTreeNode): Boolean; override;
procedure WndProc(var Msg: TMessage); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure RefreshRoot;
procedure DeleteNode(Node: TTreeNode);
procedure EditNode(Node: TTreeNode);
procedure OrganizeFavorites;
procedure ExportFavorites;
procedure ImportFavorites;
property Favorites[Index: Integer]: TGFavorite read GetFavorites; default;
property RootCaption: string read FRootCaption write SetRootCaption;
property SelectedFavorite: TGFavorite read GetSelectedFavorite;
property ShowUrlHint: Boolean read FShowUrlHint write SetShowUrlHint;
property OnUrlClick: TUrlClickEvent read FOnUrlClick write FOnUrlClick;
property OnAddFavorite: TAddFavoriteEvent read FOnAddFavorite write FOnAddFavorite;
property CanImportExport: Boolean read FCanImportExport write FCanImportExport;
end;
TGFavoritesTree = Class(TCustomGFavoritesTree)
published
property RootCaption;
property SelectedFavorite;
property OnUrlClick;
property OnAddFavorite;
property ShowUrlHint;
property CanImportExport;
property Align;
property Anchors;
property AutoExpand;
property BiDiMode;
property BorderStyle;
property BorderWidth;
property ChangeDelay;
property Color;
property Ctl3D;
property Constraints;
property DragKind;
property DragCursor;
property DragMode;
property Enabled;
property Font;
// property HideSelection;
// property HotTrack;
// property Images;
property Indent;
property ParentBiDiMode;
property ParentColor default False;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly;
// property RightClickSelect;
// property RowSelect;
// property ShowButtons;
property ShowHint;
// property ShowLines;
// property ShowRoot;
// property SortType;
// property StateImages;
property TabOrder;
property TabStop default True;
// property ToolTips;
property Visible;
property OnAdvancedCustomDraw;
property OnAdvancedCustomDrawItem;
property OnChange;
property OnChanging;
property OnClick;
property OnCollapsed;
property OnCollapsing;
property OnCompare;
property OnContextPopup;
property OnCustomDraw;
property OnCustomDrawItem;
property OnDblClick;
property OnDeletion;
property OnDragDrop;
property OnDragOver;
property OnEdited;
property OnEditing;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnExpanding;
property OnExpanded;
// property OnGetImageIndex;
// property OnGetSelectedIndex;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
property Items;
end;
procedure Register;
const
CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}';
implementation
procedure Register;
begin
RegisterComponents('Grape', [TGFavoritesTree]);
end;
{ TGFavoritesTreeNode }
constructor TGFavorite.Create(APathName: string);
begin
inherited Create;
FParent:= nil;
FFileName:= ExtractFileName(APathName);
FDisplayName:= ExtractFilePath(APathName);
FDisplayName:= Copy(FDisplayname, 1, Length(FDisplayName) - 1);
FCanDelete:= False;
FCanRename:= False;
if DirectoryExists(APathName) then
FFavoriteType:= gftFolder
else
FFavoriteType:= gftUnknown;
end;
constructor TGFavorite.Create(AParent: TGFavorite; FindFileData: TSearchRec);
begin
inherited Create;
FParent:= AParent;
FDisplayName:= ChangeFileExt(FindFileData.Name, '');
FCanDelete:= True;
FCanRename:= True;
if FindFileData.Attr = faDirectory then
FFavoriteType:= gftFolder
else
FFavoriteType:= gftUnknown;
FFileName:= FindFileData.FindData.cAlternateFileName;
if FFileName = '' then FFileName:= FindFileData.Name;
if (FFavoriteType = gftUnknown) and SameText(ExtractFileExt(FFileName), '.url') then
begin
FUrl:= GetUrl;
if FUrl <> '' then
FFavoriteType:= gftUrl
end;
end;
destructor TGFavorite.Destroy;
begin
inherited;
end;
function TGFavorite.GetPath: string;
begin
if FParent <> nil then
Result:= FParent.FullFileName
else
Result:= FDisplayName;
end;
function TGFavorite.GetFullFileName: string;
begin
Result:= Path + '/' + FFileName;
end;
function TGFavorite.GetUrl: string;
begin
Result:= '';
with TIniFile.Create(FullFileName) do
try
Result:= ReadString('InternetShortcut', 'URL', '');
finally
Free;
end;
end;
procedure TGFavorite.SetUrl(Value: string);
begin
FUrl:= Value;
with TIniFile.Create(FullFileName) do
try
WriteString('InternetShortcut', 'URL', Value);
finally
Free;
end;
end;
function TGFavorite.ComparePos(GFavorite1, GFavorite2: TGFavorite): SmallInt;
begin
if GFavorite1.FavoriteType = GFavorite2.FavoriteType then
Result:= CompareText(GFavorite1.FileName, GFavorite2.FileName)
else if GFavorite1.FavoriteType = gftFolder then
Result:= -1
else
Result:= 1;
end;
function TGFavorite.Rename(const NewName: string): boolean;
var
lpFileOp: TSHFileOpStruct;
pOldName: Array [0..MAX_PATH + 1] of Char;
pNewName: Array [0..MAX_PATH + 1] of Char;
TempStr: string;
begin
TempStr:= FullFileName;
FillChar(pOldName, MAX_PATH + 1, #0);
StrPCopy(pOldName, TempStr);
TempStr:= GetPath + '/' + NewName;
if (FavoriteType = gftUrl) and not SameText(ExtractFileExt(TempStr), '.url') then
TempStr:= TempStr + '.url';
FillChar(pNewName, MAX_PATH + 1, #0);
StrPCopy(pNewName, TempStr);
with lpFileOp do
begin
Wnd:= Application.Handle;
wFunc:= FO_RENAME;
pFrom:= pOldName;
pTo:= pNewName;
fFlags:= FOF_ALLOWUNDO + FOF_RENAMEONCOLLISION;
end;
Result:= SHFileOperation(lpFileOp) = 0;
if Result then FFileName:= NewName;
end;
function TGFavorite.Delete: Boolean;
var
lpFileOp: TSHFileOpStruct;
pFileName: Array [0..MAX_PATH + 1] of Char;
TempStr: string;
begin
TempStr:= FullFileName;
FillChar(pFileName, MAX_PATH + 1, #0);
StrPCopy(pFileName, TempStr);
with lpFileOp do
begin
Wnd:= Application.Handle;
wFunc:= FO_DELETE;
pFrom:= pFileName;
pTo:= nil;
fFlags:= FOF_ALLOWUNDO + FOF_SILENT + FOF_NOCONFIRMATION;
end;
Result:= (SHFileOperation(lpFileOp) = 0) and not lpFileOp.fAnyOperationsAborted;
end;
procedure TGFavorite.ShowProperty;
begin
end;
{ TCustomGFavoritesTree }
constructor TCustomGFavoritesTree.Create(AOwner: TComponent);
begin
inherited;
HotTrack:= True;
RowSelect:= True;
ToolTips:= True;
ShowLines:= False;
ShowButtons:= False;
ShowRoot:= False;
RightClickSelect:= True;
HideSelection:= False;
FRootCaption:= 'Favorites';
FUpdating:= False;
FLoadingRoot:= False;
FShowUrlHint:= True;
ShowHint:= True;
FCanImportExport:= GetIEVersion > 5.0;
end;
destructor TCustomGFavoritesTree.Destroy;
begin
ClearItems;
inherited;
end;
procedure TCustomGFavoritesTree.ClearItems;
var
I: Integer;
begin
for I:= 0 to Items.Count - 1 do
begin
if Items.Data <> nil then
TGFavorite(Items.Data).Free;
Items.Data:= nil;
end;
Items.Clear;
end;
procedure TCustomGFavoritesTree.Loaded;
var
FileInfo: TSHFileInfo;
TempImages: Integer;
begin
inherited Loaded;
if (csDesigning in ComponentState) then Exit;
TempImages:= SHGetFileInfo('C:/',
0, FileInfo, SizeOf(FileInfo), SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
SendMessage(Handle, TVM_SETIMAGELIST, TVSIL_NORMAL, TempImages);
CreateRoot;
end;
function TreeSortFunc(Node1, Node2: TTreeNode; lParam: Integer): Integer; stdcall;
begin
Result:= TGFavorite(Node1.Data).Parent.ComparePos(TGFavorite(Node1.Data), TGFavorite(Node2.Data));
end;
procedure TCustomGFavoritesTree.InitNode(NewNode: TTreeNode; ParentNode: TTreeNode; FindFileData: TSearchRec);
var
CanAdd: Boolean;
begin
NewNode.Data:= TGFavorite.Create(TGFavorite(ParentNode.Data), FindFileData);
with TGFavorite(NewNode.Data) do
begin
if FavoriteType = gftUnknown then
NewNode.Delete
else
begin
NewNode.Text:= DisplayName;
NewNode.ImageIndex:= GetShellImage(FullFileName, False);
NewNode.SelectedIndex:= GetShellImage(FullFileName, True);
if NewNode.SelectedIndex = 0 then NewNode.SelectedIndex:= NewNode.ImageIndex;
if FavoriteType = gftFolder then NewNode.HasChildren:= True
else NewNode.HasChildren:= False;
end;
end;
CanAdd:= True;
if Assigned(FOnAddFavorite) then FOnAddFavorite(Self, TGFavorite(NewNode.Data), CanAdd);
if not CanAdd then NewNode.Delete;
end;
procedure TCustomGFavoritesTree.PopulateNode(Node: TTreeNode);
var
NewNode: TTreeNode;
SaveCursor: TCursor;
SR : TSearchRec;
Found: Integer;
begin
if TGFavorite(Node.Data^).FavoriteType <> gftFolder then Exit;
SaveCursor:= Screen.Cursor;
Screen.Cursor:= crHourglass;
Items.BeginUpdate;
try
Found:= FindFirst(TGFavorite(Node.Data).FullFileName + '/*.*', faDirectory + faArchive, SR);
while Found = 0 do
begin
if (SR.Name <> '.') and (SR.Name <> '..') then
begin
NewNode:= Items.AddChild(Node, '');
InitNode(NewNode, Node, SR);
end;
Found:= FindNext(SR);
end;
FindClose(SR);
Node.CustomSort(@TreeSortFunc, 0);
finally
Items.EndUpdate;
Screen.Cursor:= SaveCursor;
end;
end;
procedure TCustomGFavoritesTree.CreateRoot;
var
FavoritesParh: string;
Buf: Array [0..MAX_PATH] of Char;
RootNode: TTreeNode;
begin
with TRegistry.Create do
try
RootKey:= HKEY_CURRENT_USER;
if OpenKey('/Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders', False) then
begin
FavoritesParh:= ReadString('Favorites');
ExpandEnvironmentStrings(PChar(FavoritesParh), Buf, MAX_PATH);
FavoritesParh:= Buf;
end;
finally
Free;
end;
Items.BeginUpdate;
try
if Items.Count > 0 then
ClearItems;
RootNode:= Items.Add(nil, '');
with RootNode do
begin
Data:= TGFavorite.Create(FavoritesParh);
Text:= FRootCaption;
RootNode.ImageIndex:= GetShellImage(FavoritesParh, False);
RootNode.SelectedIndex:= GetShellImage(FavoritesParh, True);
RootNode.HasChildren:= True;
end;
RootNode.Expand(False);
Selected:= RootNode;
finally
Items.EndUpdate;
end;
end;
function TCustomGFavoritesTree.CanExpand(Node: TTreeNode): Boolean;
begin
Result:= True;
if (csDesigning in ComponentState) and (Node.Level > 0) then Exit;
if Assigned(OnExpanding) then OnExpanding(Self, Node, Result);
if Result and (TGFavorite(Node.Data).FavoriteType = gftFolder) and (Node.Count = 0) then
PopulateNode(Node);
Node.HasChildren:= Node.Count > 0;
end;
procedure TCustomGFavoritesTree.Edit(const Item: TTVItem);
var
S: string;
Node: TTreeNode;
begin
with Item do
if pszText <> nil then
begin
S:= pszText;
Node:= Items.GetNode(Item.hItem);
if Assigned(OnEdited) then OnEdited(Self, Node, S);
if Node <> nil then
if Node.AbsoluteIndex = 0 then
SetRootCaption(S)
else
if TGFavorite(Node.Data).Rename(S) then Node.Text:= S
end;
end;
procedure TCustomGFavoritesTree.Delete(Node: TTreeNode);
begin
if Assigned(Node.Data) then
begin
TGFavorite(Node.Data).Free;
Node.Data:= nil;
end;
inherited Delete(Node);
end;
function TCustomGFavoritesTree.GetFavorites(Index: integer): TGFavorite;
begin
Result:= TGFavorite(Items[Index].Data);
end;
function TCustomGFavoritesTree.GetSelectedFavorite: TGFavorite;
begin
Result:= nil;
if Selected <> nil then
Result:= TGFavorite(Selected.Data)
end;
function TCustomGFavoritesTree.GetShellImage(FileName: string; Open: Boolean): Integer;
var
FileInfo: TSHFileInfo;
Flags: Integer;
begin
Flags:= SHGFI_SYSICONINDEX;
if Open then Flags:= Flags or SHGFI_OPENICON
else Flags:= Flags or SHGFI_SMALLICON;
SHGetFileInfo(PChar(FileName),
0,
FileInfo,
SizeOf(FileInfo),
Flags);
Result:= FileInfo.iIcon;
end;
procedure TCustomGFavoritesTree.SetRootCaption(Value: string);
begin
FRootCaption:= Value;
if TopItem <> nil then
TopItem.Text:= Value;
end;
procedure TCustomGFavoritesTree.DBLClick;
begin
inherited;
if Assigned(FOnUrlClick) and (SelectedFavorite <> nil)
and (SelectedFavorite.FavoriteType = gftUrl) then
begin
FOnUrlClick(Self, SelectedFavorite.Url);
end;
end;
procedure TCustomGFavoritesTree.RefreshRoot;
begin
if FUpdating then Exit;
FUpdating:= True;
try
CreateRoot;
finally
FUpdating:= False;
end;
end;
procedure TCustomGFavoritesTree.WndProc(var Msg: TMessage);
var
Node: TTreeNode;
begin
inherited;
case Msg.Msg of
WM_RBUTTONDOWN:
begin
if not(csDesigning in ComponentState) then
begin
Node:= GetNodeAt(LOWORD(Msg.lParam), HIWORD(Msg.LParam));
if Node <> nil then Node.Selected:= true;
end;
end;
WM_MOUSEMOVE:
begin
if FShowUrlHint then
begin
Node:= GetNodeAt(LOWORD(Msg.lParam), HIWORD(Msg.lParam));
if (Node <> nil) and (Node.Data <> nil) then Hint:= TGFavorite(Node.Data).Url;
end;
end;
end;
end;
procedure TCustomGFavoritesTree.DeleteNode(Node: TTreeNode);
begin
if (Node = nil) or (Node.Data = nil) or not TGFavorite(Node.Data).CanDelete then exit;
if TGFavorite(Node.Data).Delete then
Node.Delete;
end;
procedure TCustomGFavoritesTree.EditNode(Node: TTreeNode);
begin
if (Node = nil) or (Node.Data = nil) then exit;
Node.Selected:= True;
Node.EditText;
end;
procedure TCustomGFavoritesTree.OrganizeFavorites;
var
H: HWnd;
p: procedure(Handle: THandle; Path: PChar); stdcall;
begin
H:= LoadLibrary(PChar('shdocvw.dll'));
if H <> 0 then begin
p:= GetProcAddress(H, PChar('DoOrganizeFavDlg'));
if Assigned(p) then p(Application.Handle, PChar(Favorites[0].FullFileName));
end;
FreeLibrary(h);
RefreshRoot;
end;
procedure TCustomGFavoritesTree.ExportFavorites;
var
Sh: ISHellUIHelper;
begin
Sh:= CreateComObject(CLSID_SHELLUIHELPER) as ISHELLUIHELPER;
sh.ImportExportFavorites(FALSE, '');
end;
procedure TCustomGFavoritesTree.ImportFavorites;
var
Sh: ISHellUIHelper;
begin
Sh:= CreateComObject(CLSID_SHELLUIHELPER) as ISHELLUIHELPER;
sh.ImportExportFavorites(TRUE, '');
RefreshRoot;
end;
function TCustomGFavoritesTree.GetIEVersion: Extended;
var
Reg: TRegistry;
S: string;
Code: integer;
begin
Reg:= TRegistry.Create;
with Reg do begin
RootKey:= HKEY_LOCAL_MACHINE;
OpenKey('Software/Microsoft/Internet Explorer', False);
if ValueExists('Version') then S:= ReadString('Version')
else S:= '0';
CloseKey;
Free;
end;
Val(System.Copy(S, 1, 3), Result, Code);
if Code <> 0 then Result:= 1.0;
end;
procedure TCustomGFavoritesTree.SetShowUrlHint(Value: Boolean);
begin
FShowUrlHint:= Value;
if Value then ShowHint:= True;
end;
end.