Author: Christian Cristofori
The enhanced version of my CreateTreeMenus
Answer:
You nedd to create only a ImageList and a Menu.
1
2 procedure TfrmMain.CreateTreeMenus(Path: string; Root: TMenuItem; ListImage:
3 TImageList);
4 type
5 pHIcon = ^HIcon;
6 var
7 SR: TSearchRec;
8 Result: Integer;
9 Item: TMenuItem;
10 SmallIcon: HIcon;
11 IconA: TIcon;
12 BitMapA: TBitMap;
13 Indice: Integer;
14 procedure GetAssociatedIcon(FileName: TFilename; pLargeIcon, PSmallIcon: pHIcon);
15 var
16 IconIndex: Word;
17 FileExt: string;
18 FileType: string;
19 Reg: TRegistry;
20 p: Integer;
21 p1: pChar;
22 p2: pChar;
23 function GetSystemDir: TFileName;
24 var
25 SysDir: array[0..MAX_PATH - 1] of Char;
26 begin
27 SetString(Result, SysDir, GetSystemDirectory(SysDir, MAX_PATH));
28 if (Result = '') then
29 raise Exception.Create(SysErrorMessage(GetLastError));
30 end;
31 label
32 NoAssoc;
33 begin
34 IconIndex := 0;
35 FileExt := UpperCase(ExtractFileExt(FileName));
36 if (((FileExt <> '.EXE') and (FileExt <> '.ICO')) or (not
37 (FileExists(FileName))))
38 then
39 begin
40 Reg := nil;
41 try
42 Reg := TRegistry.Create(KEY_QUERY_VALUE);
43 Reg.RootKey := HKEY_CLASSES_ROOT;
44 if (FileExt = '.EXE') then
45 FileExt := '.COM';
46 if (Reg.OpenKeyReadOnly(FileExt)) then
47 try
48 FileType := Reg.ReadString('');
49 finally
50 Reg.CloseKey;
51 end;
52 if ((FileType <> '') and Reg.OpenKeyReadOnly(FileType + '\DefaultIcon'))
53 then
54 try
55 FileName := Reg.ReadString('');
56 finally
57 Reg.CloseKey;
58 end;
59 finally
60 Reg.Free;
61 end;
62 if (FileName = '') then
63 goto NoAssoc;
64 p1 := PChar(FileName);
65 p2 := StrRScan(p1, ',');
66 if (p2 <> nil) then
67 begin
68 p := p2 - p1 + 1;
69 IconIndex := StrToInt(Copy(FileName, p + 1, Length(FileName) - p));
70 SetLength(FileName, p - 1);
71 end;
72 end;
73 if (ExtractIconEx(PChar(FileName), IconIndex, PLargeIcon^, PSmallIcon^, 1) <> 1)
74 then
75 begin
76 NoAssoc:
77 try
78 FileName := IncludeTrailingBackslash(GetSystemDir) + 'SHELL32.DLL';
79 except
80 FileName := 'C:\WINDOWS\SYSTEM\SHELL32.DLL';
81 end;
82 if (FileExt = '.DOC') then
83 IconIndex := 1
84 else if ((FileExt = '.EXE') or (FileExt = '.COM')) then
85 IconIndex := 2
86 else if (FileExt = '.HLP') then
87 IconIndex := 23
88 else if ((FileExt = '.INI') or (FileExt = '.INF')) then
89 IconIndex := 63
90 else if (FileExt = '.TXT') then
91 IconIndex := 64
92 else if (FileExt = '.BAT') then
93 IconIndex := 65
94 else if ((FileExt = '.DLL') or (FileExt = '.SYS') or (FileExt = '.VBX') or
95 (FileExt = '.OCX') or (FileExt = '.VXD')) then
96 IconIndex := 66
97 else if (FileExt = '.FON') then
98 IconIndex := 67
99 else if (FileExt = '.TTF') then
100 IconIndex := 68
101 else if (FileExt = '.FOT') then
102 IconIndex := 69
103 else
104 IconIndex := 0;
105 if ((ExtractIconEx(PChar(FileName), IconIndex, PLargeIcon^, PSmallIcon^, 1) <>
106 1)) then
107 begin
108 if (PLargeIcon <> nil) then
109 PLargeIcon^ := 0;
110 if (PSmallIcon <> nil) then
111 PSmallIcon^ := 0;
112 end;
113 end;
114 end;
115 begin
116 Path := IncludeTrailingBackSlash(Path);
117 Result := FindFirst(Path + '*.*', faDirectory, SR);
118 while (Result = 0) do
119 begin
120 if (((SR.Attr and faDirectory) <> 0) and (SR.Name <> '.') and (SR.Name <> '..'))
121 then
122 begin
123 Item := TMenuItem.Create(Self);
124 Item.Caption := SR.Name;
125 Item.ImageIndex := 0;
126 Root.Add(Item);
127 CreateTreeMenus(Path + SR.Name, Item, ListImage);
128 end;
129 if (((SR.Attr and faAnyFile) <> 0) and (SR.Name <> '.') and (SR.Name <> '..'))
130 then
131 begin
132 Item := TMenuItem.Create(Self);
133 Item.Caption := SR.Name;
134 GetAssociatedIcon(sr.Name, nil, @SmallIcon);
135 IconA := TIcon.Create;
136 IconA.Handle := SmallIcon;
137 BitMapA := TBitMap.Create;
138 BitMapA.Width := IconA.Width;
139 BitMapA.Height := IconA.Height;
140 BitMapA.Canvas.Draw(0, 0, IconA);
141 BitMapA.TransparentMode := tmAuto;
142 Indice := ListImage.Add(BitMapA, nil);
143 Item.ImageIndex := Indice;
144 Root.Add(Item);
145 end;
146 Result := FindNext(SR);
147 end;
148 SysUtils.FindClose(SR);
149 end;
150
151 procedure TfrmMain.FormCreate(Sender: TObject);
152 begin
153 CreateTreeMenus('c:\projects\', directory1, ImageList1);
154 end;
You can also use shgetfileinfo with SHGFI_ICON parameter in the place of checking individual file extension.
|
