Details | Last modification | View Log | RSS feed
Rev | Author | Line No. | Line |
---|---|---|---|
2 | daniel-mar | 1 | unit ExplorerForm; |
2 | |||
3 | // TODO: Detailansicht: - Skalieren der Spalten |
||
4 | // - Mehr Eigenschaften zeigen, die in der SQL-Datenbank sind |
||
5 | |||
6 | interface |
||
7 | |||
8 | uses |
||
9 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, |
||
10 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls, |
||
11 | System.ImageList, Vcl.ImgList, Data.DB, Data.Win.ADODB, Vcl.Samples.Gauges, |
||
12 | Vcl.Buttons, Vcl.ExtCtrls, Vcl.Menus; |
||
13 | |||
14 | type |
||
15 | TfrmExplorer = class(TForm) |
||
16 | ListView1: TListView; |
||
17 | Button2: TButton; |
||
18 | ImageListSmall: TImageList; |
||
19 | ImageListLarge: TImageList; |
||
20 | Label1: TLabel; |
||
21 | SpeedButton1: TSpeedButton; |
||
22 | Timer1: TTimer; |
||
23 | PopupMenu1: TPopupMenu; |
||
24 | Checkifdirisredundant1: TMenuItem; |
||
25 | ReIndexthisitem1: TMenuItem; |
||
26 | procedure Button2Click(Sender: TObject); |
||
27 | procedure ListView1DblClick(Sender: TObject); |
||
28 | procedure SpeedButton1Click(Sender: TObject); |
||
29 | procedure FormClose(Sender: TObject; var Action: TCloseAction); |
||
30 | procedure Timer1Timer(Sender: TObject); |
||
31 | procedure Checkifdirisredundant1Click(Sender: TObject); |
||
32 | procedure ReIndexthisitem1Click(Sender: TObject); |
||
33 | procedure ListView1KeyDown(Sender: TObject; var Key: Word; |
||
34 | Shift: TShiftState); |
||
35 | procedure FormShow(Sender: TObject); |
||
36 | private |
||
37 | FCurrentFolder: string; |
||
38 | FCurrentDepth: integer; |
||
39 | procedure SetCurrentFolder(const Value: string); |
||
40 | procedure SetCurrentDepth(const Value: integer); |
||
41 | property CurrentFolder: string read FCurrentFolder write SetCurrentFolder; |
||
42 | property CurrentDepth: integer read FCurrentDepth write SetCurrentDepth; |
||
43 | protected |
||
44 | procedure FillListView(sl: TStrings); |
||
45 | public |
||
46 | procedure OpenFolder(const folder: string); |
||
47 | procedure ListDevices; |
||
48 | procedure PrevFolder; |
||
49 | function conn: TAdoConnection; |
||
50 | function TableName: string; |
||
51 | end; |
||
52 | |||
53 | implementation |
||
54 | |||
55 | {$R *.dfm} |
||
56 | |||
57 | uses |
||
58 | ShellAPI, System.Types, AdoConnHelper, RedundancyForm, IndexCreatorForm, MainForm, |
||
59 | IniFiles; |
||
60 | |||
61 | function AddTransparentIconToImageList(ImageList: TImageList; Icon: TIcon; DoGreyscale: boolean=False): integer; |
||
62 | // http://www.delphipages.com/forum/showthread.php?t=183999 |
||
63 | |||
64 | function RealIconSize(H: HIcon): TPoint; |
||
65 | // http://www.delphipages.com/forum/showthread.php?t=183999 |
||
66 | var |
||
67 | IconInfo: TIconInfo; |
||
68 | bmpmask: TBitmap; |
||
69 | begin |
||
70 | result := Point(0, 0); |
||
71 | |||
72 | if H <> 0 then |
||
73 | begin |
||
74 | bmpmask := TBitmap.Create; |
||
75 | try |
||
76 | IconInfo.fIcon := true; |
||
77 | try |
||
78 | GetIconInfo(H, IconInfo); |
||
79 | bmpmask.Handle := IconInfo.hbmMask; |
||
80 | bmpmask.Dormant; //lets us free the resource without 'losing' the bitmap |
||
81 | finally |
||
82 | DeleteObject(IconInfo.hbmMask); |
||
83 | DeleteObject(IconInfo.hbmColor) |
||
84 | end; |
||
85 | result := Point(bmpmask.Width, bmpmask.Height); |
||
86 | finally |
||
87 | bmpmask.Free; |
||
88 | end; |
||
89 | end; |
||
90 | end; |
||
91 | |||
92 | function ToGray(PixelColor: Longint): Longint; |
||
93 | var |
||
94 | Red, Green, Blue, Gray: Byte; |
||
95 | begin |
||
96 | Red := PixelColor; |
||
97 | Green := PixelColor shr 8; |
||
98 | Blue := PixelColor shr 16; |
||
99 | Gray := Round(0.299 * Red + 0.587 * Green + 0.114 * Blue); |
||
100 | result := Gray + Gray shl 8 + Gray shl 16; |
||
101 | end; |
||
102 | |||
103 | var |
||
104 | buffer, mask: TBitmap; |
||
105 | p: TPoint; |
||
106 | x, y: integer; |
||
107 | begin |
||
108 | // result := ImageList.AddIcon(ico); |
||
109 | // --> In Delphi 6, Icons with half-transparency have a black border (e.g. in ListView) |
||
110 | |||
111 | p := RealIconSize(icon.handle); |
||
112 | |||
113 | buffer := TBitmap.Create; |
||
114 | mask := TBitmap.Create; |
||
115 | try |
||
116 | buffer.PixelFormat := pf24bit; |
||
117 | mask.PixelFormat := pf24bit; |
||
118 | |||
119 | buffer.Width := p.X; |
||
120 | buffer.Height := p.Y; |
||
121 | buffer.Canvas.Draw(0, 0, icon); |
||
122 | buffer.Transparent := true; |
||
123 | buffer.TransparentColor := buffer.Canvas.Pixels[0,0]; |
||
124 | |||
125 | if (ImageList.Width <> p.X) or (ImageList.Height <> p.Y) then |
||
126 | begin |
||
127 | ImageList.Width := p.X; |
||
128 | ImageList.Height := p.Y; |
||
129 | end; |
||
130 | |||
131 | // create a mask for the icon. |
||
132 | mask.Assign(buffer); |
||
133 | mask.Canvas.Brush.Color := buffer.Canvas.Pixels[0, buffer.Height -1]; |
||
134 | mask.Monochrome := true; |
||
135 | |||
136 | if DoGreyscale then |
||
137 | begin |
||
138 | for x := 0 to buffer.Width - 1 do |
||
139 | begin |
||
140 | for y := 0 to buffer.Height - 1 do |
||
141 | begin |
||
142 | buffer.Canvas.Pixels[x, y] := ToGray(buffer.Canvas.Pixels[x, y]); |
||
143 | end; |
||
144 | end; |
||
145 | end; |
||
146 | |||
147 | result := ImageList.Add(buffer, mask); |
||
148 | finally |
||
149 | mask.Free; |
||
150 | buffer.Free; |
||
151 | end; |
||
152 | end; |
||
153 | |||
154 | procedure TfrmExplorer.Button2Click(Sender: TObject); |
||
155 | begin |
||
156 | // TODO: Refreshen wegen Anzeigefehler |
||
157 | ListView1.ViewStyle := TViewStyle((Ord(ListView1.ViewStyle)+1) mod (Ord(High(TViewStyle))+1)); |
||
158 | end; |
||
159 | |||
160 | procedure TfrmExplorer.Checkifdirisredundant1Click(Sender: TObject); |
||
161 | begin |
||
162 | if ListView1.ItemIndex = -1 then exit; |
||
163 | |||
164 | with TfrmRedundancy.Create(Owner) do |
||
165 | begin |
||
166 | Edit1.Text := CurrentFolder + ListView1.Selected.Caption; |
||
167 | end; |
||
168 | end; |
||
169 | |||
170 | function TfrmExplorer.conn: TAdoConnection; |
||
171 | begin |
||
172 | result := frmMain.ADOConnection1; |
||
173 | end; |
||
174 | |||
175 | procedure TfrmExplorer.FillListView(sl: TStrings); |
||
176 | var |
||
177 | s: string; |
||
178 | i: Integer; |
||
179 | Icon: TIcon; |
||
180 | Extention : string; |
||
181 | FileInfo : SHFILEINFO; |
||
182 | attr: Cardinal; |
||
183 | begin |
||
184 | ListView1.Clear; |
||
185 | Icon := TIcon.Create; |
||
186 | ImageListSmall.Clear; |
||
187 | ImageListSmall.Width := 16; |
||
188 | ImageListSmall.Height := 16; |
||
189 | ImageListLarge.Clear; |
||
190 | ImageListLarge.Width := 32; |
||
191 | ImageListLarge.Height := 32; |
||
192 | for i := 0 to sl.Count-1 do |
||
193 | begin |
||
194 | s := sl.Strings[i]; |
||
195 | with ListView1.Items.Add do |
||
196 | begin |
||
197 | Extention := '*' + ExtractFileExt(s); |
||
198 | |||
199 | if Pos('\', s) = 0 then |
||
200 | begin |
||
201 | attr := FILE_ATTRIBUTE_NORMAL; |
||
202 | Caption := s; |
||
203 | Data := Pointer(0); |
||
204 | end |
||
205 | else |
||
206 | begin |
||
207 | attr := FILE_ATTRIBUTE_DIRECTORY; |
||
208 | Caption := Copy(s, 1, Length(s)-1); // remove trailing "\" |
||
209 | Data := Pointer(1); |
||
210 | end; |
||
211 | |||
212 | {$REGION 'File extention name'} |
||
213 | SHGetFileInfo(PChar(Extention), |
||
214 | attr, |
||
215 | FileInfo, |
||
216 | SizeOf(FileInfo), |
||
217 | SHGFI_TYPENAME or SHGFI_USEFILEATTRIBUTES |
||
218 | ); |
||
219 | SubItems.Add(FileInfo.szTypeName); |
||
220 | {$ENDREGION} |
||
221 | |||
222 | {$REGION 'Small icon'} |
||
223 | SHGetFileInfo(PChar(Extention), |
||
224 | attr, |
||
225 | FileInfo, |
||
226 | SizeOf(FileInfo), |
||
227 | SHGFI_ICON or SHGFI_SMALLICON or |
||
228 | SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES |
||
229 | ); |
||
230 | Icon.Handle := FileInfo.hIcon; |
||
231 | AddTransparentIconToImageList(ImageListSmall, Icon, false); // ImageListSmall.AddIcon(Icon); |
||
232 | {$ENDREGION} |
||
233 | |||
234 | {$REGION 'Large icon'} |
||
235 | SHGetFileInfo(PChar(Extention), |
||
236 | attr, |
||
237 | FileInfo, |
||
238 | SizeOf(FileInfo), |
||
239 | SHGFI_ICON or SHGFI_LARGEICON or |
||
240 | SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES |
||
241 | ); |
||
242 | Icon.Handle := FileInfo.hIcon; |
||
243 | AddTransparentIconToImageList(ImageListLarge, Icon, false); // ImageListLarge.AddIcon(Icon); |
||
244 | {$ENDREGION} |
||
245 | |||
246 | ImageIndex := i; |
||
247 | end; |
||
248 | end; |
||
249 | Icon.Free; |
||
250 | end; |
||
251 | |||
252 | procedure TfrmExplorer.FormClose(Sender: TObject; var Action: TCloseAction); |
||
253 | begin |
||
254 | Action := caFree; |
||
255 | end; |
||
256 | |||
257 | procedure TfrmExplorer.FormShow(Sender: TObject); |
||
258 | var |
||
259 | ini: TMemIniFile; |
||
260 | begin |
||
261 | ini := frmMain.ini; |
||
262 | // Edit1.Text := ini.ReadString('Explorer', 'DefaultDir', ''); |
||
263 | end; |
||
264 | |||
265 | procedure TfrmExplorer.ListDevices; |
||
266 | var |
||
267 | q: TADODataSet; |
||
268 | sl: TStringList; |
||
269 | begin |
||
270 | label1.Caption := '*** PLEASE WAIT ***'; |
||
271 | Application.ProcessMessages; |
||
272 | |||
273 | sl := TStringList.Create; |
||
274 | |||
275 | q := conn.GetTable('select distinct left(filename,charindex('':\'',filename,0)) from '+TableName+' where filename not like ''\\%'';'); |
||
276 | while not q.Eof do |
||
277 | begin |
||
278 | sl.Add(q.Fields[0].AsString+'\'); // e.g. "C:" or "EHDD:" for ViaThinkSoft |
||
279 | q.Next; |
||
280 | end; |
||
281 | q.Free; |
||
282 | |||
283 | q := conn.GetTable('select distinct left(filename,charindex(''\'',filename,3)-1) from '+TableName+' where filename like ''\\%'' and filename not like ''\\?\%'';'); |
||
284 | while not q.Eof do |
||
285 | begin |
||
286 | sl.Add(q.Fields[0].AsString+'\'); // e.g. "\\server1" |
||
287 | q.Next; |
||
288 | end; |
||
289 | q.Free; |
||
290 | |||
291 | q := conn.GetTable('select distinct left(filename,charindex(''\'',filename,5)-1) from '+TableName+' where filename like ''\\?\%'';'); |
||
292 | while not q.Eof do |
||
293 | begin |
||
294 | sl.Add(q.Fields[0].AsString+'\'); // e.g. "\\?\Volume{560e8251-2b6a-4ab7-82fc-d03df4d93538}" |
||
295 | q.Next; |
||
296 | end; |
||
297 | q.Free; |
||
298 | |||
299 | FillListView(sl); |
||
300 | CurrentFolder := ''; |
||
301 | CurrentDepth := 0; |
||
302 | end; |
||
303 | |||
304 | procedure TfrmExplorer.ListView1DblClick(Sender: TObject); |
||
305 | begin |
||
306 | if ListView1.ItemIndex = -1 then exit; |
||
307 | if ListView1.Selected.Data = Pointer(0) then |
||
308 | begin |
||
309 | // Ist eine Datei |
||
310 | ShowMessageFmt('Filename: %s', [ListView1.Selected.Caption]); |
||
311 | end; |
||
312 | if ListView1.Selected.Data = Pointer(1) then |
||
313 | begin |
||
314 | // Ist ein Verzeichnis |
||
315 | OpenFolder(CurrentFolder + ListView1.Selected.Caption + '\'); |
||
316 | end; |
||
317 | end; |
||
318 | |||
319 | procedure TfrmExplorer.ListView1KeyDown(Sender: TObject; var Key: Word; |
||
320 | Shift: TShiftState); |
||
321 | begin |
||
322 | if Key = VK_BACK then |
||
323 | begin |
||
324 | if SpeedButton1.Enabled then SpeedButton1.Click; |
||
325 | Key := 0; |
||
326 | end; |
||
327 | if Key = VK_RETURN then |
||
328 | begin |
||
329 | ListView1DblClick(ListView1); |
||
330 | Key := 0; |
||
331 | end; |
||
332 | end; |
||
333 | |||
334 | procedure TfrmExplorer.OpenFolder(const folder: string); |
||
335 | var |
||
336 | sl: TStringList; |
||
337 | q: TADODataSet; |
||
338 | p: Integer; |
||
339 | DirName: string; |
||
340 | locFolder: string; |
||
341 | relfilepath: string; |
||
342 | folders: TStringList; |
||
343 | begin |
||
344 | label1.Caption := '*** PLEASE WAIT ***'; |
||
345 | Application.ProcessMessages; |
||
346 | |||
347 | sl := TStringList.Create; |
||
348 | folders := TStringList.Create; |
||
349 | try |
||
350 | //q := conn.GetTable('select filename from '+TableName+' where filename like '+conn.SQLStringEscape(Folder+'%')); |
||
351 | q := conn.GetTable('select distinct left(filename,charindex(''\'',filename+''\'','+inttostr(Length(Folder)+1)+')) from '+TableName+' where filename like '+conn.SQLStringEscape(Folder+'%')); |
||
352 | |||
353 | //gauge1.MaxValue := q.RecordCount; |
||
354 | //Gauge1.Progress := 0; |
||
355 | while not q.EOF do |
||
356 | begin |
||
357 | relfilepath := q.Fields[0].AsString; |
||
358 | Delete(relfilepath, 1, Length(Folder)); |
||
359 | p := Pos('\', relfilepath); |
||
360 | if p > 0 then |
||
361 | begin |
||
362 | // Ist ein Verzeichnis |
||
363 | DirName := Copy(relfilepath, 1, p); |
||
364 | if folders.IndexOf(DirName) = -1 then folders.Add(DirName); |
||
365 | end |
||
366 | else |
||
367 | begin |
||
368 | sl.Add(ExtractFileName(relfilepath)); |
||
369 | end; |
||
370 | q.Next; |
||
371 | //Gauge1.Progress := Gauge1.Progress + 1; |
||
372 | end; |
||
373 | q.Free; |
||
374 | for locFolder in folders do |
||
375 | begin |
||
376 | sl.Add(locFolder); |
||
377 | end; |
||
378 | FillListView(sl); |
||
379 | CurrentFolder := folder; |
||
380 | CurrentDepth := CurrentDepth + 1; |
||
381 | finally |
||
382 | sl.Free; |
||
383 | folders.Free; |
||
384 | end; |
||
385 | end; |
||
386 | |||
387 | procedure TfrmExplorer.PrevFolder; |
||
388 | begin |
||
389 | label1.Caption := '*** PLEASE WAIT ***'; |
||
390 | Application.ProcessMessages; |
||
391 | |||
392 | if CurrentDepth = 1 then |
||
393 | begin |
||
394 | ListDevices; |
||
395 | end |
||
396 | else |
||
397 | begin |
||
398 | OpenFolder(IncludeTrailingPathDelimiter(ExtractFileDir(Copy(CurrentFolder,1,Length(CurrentFolder)-1)))); |
||
399 | CurrentDepth := CurrentDepth - 2; |
||
400 | end; |
||
401 | end; |
||
402 | |||
403 | procedure TfrmExplorer.ReIndexthisitem1Click(Sender: TObject); |
||
404 | begin |
||
405 | if ListView1.ItemIndex = -1 then exit; |
||
406 | |||
407 | with TfrmIndexCreator.Create(Owner) do |
||
408 | begin |
||
409 | LabeledEdit2.Text := CurrentFolder + ListView1.Selected.Caption; |
||
410 | end; |
||
411 | end; |
||
412 | |||
413 | procedure TfrmExplorer.SetCurrentDepth(const Value: integer); |
||
414 | begin |
||
415 | SpeedButton1.Visible := Value > 0; |
||
416 | FCurrentDepth := Value; |
||
417 | end; |
||
418 | |||
419 | procedure TfrmExplorer.SetCurrentFolder(const Value: string); |
||
420 | begin |
||
421 | Label1.Caption := Value; |
||
422 | FCurrentFolder := Value; |
||
423 | end; |
||
424 | |||
425 | procedure TfrmExplorer.SpeedButton1Click(Sender: TObject); |
||
426 | begin |
||
427 | PrevFolder; |
||
428 | end; |
||
429 | |||
430 | function TfrmExplorer.TableName: string; |
||
431 | begin |
||
432 | result := frmMain.TableName; |
||
433 | end; |
||
434 | |||
435 | procedure TfrmExplorer.Timer1Timer(Sender: TObject); |
||
436 | begin |
||
437 | timer1.Enabled := false; |
||
438 | ListDevices; |
||
439 | end; |
||
440 | |||
441 | end. |