source: oup/current/ImportedStuff/FolderBrowser.pas@ 102

Last change on this file since 102 was 90, checked in by alloc, 18 years ago
File size: 16.8 KB
RevLine 
[90]1// -----------------------------------------------------------------------------
2//
3// TFolderBrowser-Klasse
4// Copyright (c) 2003-2005 Delphi-Forum
5// Tino, Popov, Christian Stelzman (PL), Luckie, Aton, Mathias Simmack (msi)
6//
7// basiert auf den folgenden Beiträgen
8// - http://www.delphi-forum.de/viewtopic.php?t=11240
9// - http://www.delphi-forum.de/viewtopic.php?t=21471
10// * http://www.delphi-forum.de/viewtopic.php?t=25302
11// - http://www.delphi-forum.de/viewtopic.php?t=27010&start=0
12//
13// -----------------------------------------------------------------------------
14
15// -- Revision history ---------------------------------------------------------
16//
17// * ursprüngliche Version von PL (s. Link #3)
18// * Fehlerkorrekturen von Luckie
19// - Result bei Callback ergänzt
20// - Properties als private deklariert
21// - Bugs in "Execute"-Methode behoben
22// * Dateifilter in Callback-Funktion
23// - Idee (Aton)
24// - globale Stringvariable (msi)
25// - TFolderBrowser-Klasse (PL)
26// * Unterstützung für mehrere Filter ergänzt (msi)
27// * Unterstützung für verschiedene Root-Ordner (msi)
28// * Änderungen bei den Properties (msi)
29// - "SelFolder" in "SelectedItem" umbenannt
30// - "FNewFolder" als "NewFolderButton" verfügbar
31// - "FShowFiles" als "ShowFiles" verfügbar
32// - "FNoTT" als "NoTargetTranslation" verfügbar (XP-Flag)
33// * Funktion zum Ermitteln von Verknüpfungszielen ergänzt (msi)
34// - Ergänzung, um Umgebungsvariablen umzuwandeln
35// * "InitFolder" (s. Create) umbenannt in "PreSelectedFolder" (PL)
36// * "FNoTT" (NoTargetTranslation) standardmäßig auf TRUE gesetzt,
37// damit alle Windows-Versionen, inkl. XP, gleich reagieren (msi)
38// * "CoInitializeEx" (Execute & TranslateLink) geändert (msi)
39// * "TranslateMsiLink" (PL, msi)
40// - ermittelt Pfad/Programm aus MSI-Verknüpfungen (Office, Openoffice)
41// - benötigt installierten MSI
42//
43// -----------------------------------------------------------------------------
44unit FolderBrowser;
45
46
47interface
48
49uses
50 ShlObj, ActiveX, Windows, Messages;
51
52type
53 TFolderBrowser = class
54 private
55 // alles private gemacht; geht niemanden was an,
56 // da nachträglicher Zugriff sinnlos (Luckie)
57 FHandle : THandle;
58 FCaption : string;
59 FShowFiles : boolean;
60 FNewFolder : boolean;
61 FStatusText : boolean;
62 FNoTT : boolean;
63 FInitFolder : string;
64 FSelected : string;
65 FTop,
66 FLeft : integer;
67 FPosChanged : boolean;
68
69 // mehrere Filter müssen durch #0 voneinander getrennt
70 // werden, bspw. '*.txt'#0'*.*htm*'#0'*.xml'
71 // der letzte Filter kann mit #0#0 enden, muss er aber
72 // nicht, weil die Funktion "CheckFilter" diese beiden
73 // Zeichen automatisch anhängt (Mathias)
74 FFilter : string;
75 FRoot : PItemIdList;
76 procedure FreeItemIDList(var pidl: pItemIDList);
77 procedure SetTopPosition(const Value: Integer);
78 procedure SetLeftPosition(const Value: Integer);
79 public
80 constructor Create(Handle: THandle; const Caption: string;
81 const PreSelectedFolder: string = ''; ShowFiles: Boolean = False;
82 NewFolder: Boolean = False);
83 destructor Destroy; override;
84 function SetDefaultRoot: boolean;
85 function SetRoot(const SpecialFolderId: integer): boolean; overload;
86 function SetRoot(const Path: string): boolean; overload;
87 function Execute: Boolean; overload;
88 function TranslateLink(const LnkFile: string): string;
89 function TranslateMsiLink(const LnkFile: string): string;
90 property SelectedItem: string read FSelected;
91 property Filter: string read FFilter write FFilter;
92 property NewFolderButton: boolean read FNewFolder write FNewFolder;
93 property ShowFiles: boolean read FShowFiles write FShowFiles;
94 property StatusText: boolean read FStatusText write FStatusText;
95 property NoTargetTranslation: boolean read FNoTT write FNoTT;
96 property Top: integer read FTop write SetTopPosition;
97 property Left: integer read FLeft write SetLeftPosition;
98 end;
99
100implementation
101
102
103//
104// erweiterte SHBrowseForFolder-Eigenschaften
105// (Deklaration ist notwendig, weil u.U. nicht in jeder Delphi-Version
106// bekannt und verfügbar)
107//
108const
109 BIF_NEWDIALOGSTYLE = $0040;
110 BIF_USENEWUI = BIF_NEWDIALOGSTYLE or BIF_EDITBOX;
111 BIF_BROWSEINCLUDEURLS = $0080;
112 BIF_UAHINT = $0100;
113 BIF_NONEWFOLDERBUTTON = $0200;
114 BIF_NOTRANSLATETARGETS = $0400;
115 BIF_SHAREABLE = $8000;
116
117 BFFM_IUNKNOWN = 5;
118 BFFM_SETOKTEXT = WM_USER + 105; // Unicode only
119 BFFM_SETEXPANDED = WM_USER + 106; // Unicode only
120
121
122// -- helper functions ---------------------------------------------------------
123
124function fileexists(const FileName: string): boolean;
125var
126 Handle : THandle;
127 FindData : TWin32FindData;
128begin
129 Handle := FindFirstFile(pchar(FileName),FindData);
130 Result := (Handle <> INVALID_HANDLE_VALUE);
131
132 if(Result) then FindClose(Handle);
133end;
134
135function CheckFilter(const Path, Filter: string): boolean;
136var
137 p : pchar;
138begin
139 // Standardergebnis
140 Result := false;
141 if(Path = '') or (Filter = '') then exit;
142
143 // #0#0 an den Filter anhängen, damit später das Ende
144 // korrekt erkannt wird
145 p := pchar(Filter + #0#0);
146 while(p[0] <> #0) do
147 begin
148 // Datei mit entsprechendem Filter wurde gefunden, ...
149 if(fileexists(Path + '\' + p)) then
150 begin
151 // ... Ergebnis auf TRUE setzen, und Schleife abbrechen
152 Result := true;
153 break;
154 end;
155
156 // ansonsten zum nächsten Filter
157 inc(p,lstrlen(p) + 1);
158 end;
159end;
160
161function SHGetIDListFromPath(const Path: string; out pidl: PItemIDList):
162 boolean;
163var
164 ppshf : IShellFolder;
165 wpath : array[0..MAX_PATH]of widechar;
166 pchEaten,
167 dwAttributes : Cardinal;
168begin
169 // Standardergebnis
170 Result := false;
171
172 // IShellFolder-Handle holen
173 if(SHGetDesktopFolder(ppshf) = S_OK) then
174 try
175 if(StringToWideChar(Path,wpath,sizeof(wpath)) <> nil) then
176 begin
177 // Pfadname in "PItemIdList" umwandeln
178 ppshf.ParseDisplayName(0,nil,wpath,pchEaten,pidl,dwAttributes);
179 Result := pidl <> nil;
180 end;
181 finally
182 ppshf := nil;
183 end;
184end;
185
186//
187// "CreateComObject" (modifizierte Version; Mathias)
188//
189function CreateComObject(const ClassID: TGUID;
190 out OleResult : HRESULT): IUnknown;
191begin
192 OleResult := CoCreateInstance(ClassID,nil,CLSCTX_INPROC_SERVER or
193 CLSCTX_LOCAL_SERVER,IUnknown,Result);
194end;
195
196//
197// "ExpandEnvStr"
198//
199function ExpandEnvStr(const szInput: string): string;
200const
201 MAXSIZE = 32768;
202begin
203 SetLength(Result,MAXSIZE);
204 SetLength(Result,ExpandEnvironmentStrings(pchar(szInput),
205 @Result[1],length(Result)));
206end;
207
208
209
210// -----------------------------------------------------------------------------
211//
212// TFolderBrowser-Klasse
213//
214// -----------------------------------------------------------------------------
215
216function FolderCallback(wnd: HWND; uMsg: UINT; lp, lpData: LPARAM): LRESULT;
217 stdcall;
218var
219 path : array[0..MAX_PATH + 1]of char;
220 fb : TFolderBrowser;
221begin
222 fb := TFolderBrowser(lpData);
223
224 case uMsg of
225 // Dialog wurde initialisiert
226 BFFM_INITIALIZED:
227 begin
228 // Ordner auswählen, ...
229 if(fb.FInitFolder <> '') then
230 SendMessage(wnd,BFFM_SETSELECTION,WPARAM(true),
231 LPARAM(pchar(fb.FInitFolder)));
232
233 // ... & OK-Button deaktivieren, wenn Filter benutzt werden
234 SendMessage(wnd,BFFM_ENABLEOK,0,LPARAM(fb.FFilter = ''));
235 // oder anders gesagt: OK-Button aktivieren, wenn keine
236 // Filter benutzt werden. ;o)
237 // (Mathias)
238
239 // Dialog neu positionieren
240 if(fb.FPosChanged) then
241 SetWindowPos(wnd,0,fb.Left,fb.Top,0,0,SWP_NOSIZE or SWP_NOZORDER);
242 end;
243 BFFM_SELCHANGED:
244 if(PItemIdList(lp) <> nil) and (fb.FFilter <> '') then
245 begin
246 // den aktuellen Pfadnamen holen, ...
247 ZeroMemory(@path,sizeof(path));
248 if(SHGetPathFromIdList(PItemIdList(lp),path)) then
249 begin
250 // ... & anzeigen
251 SendMessage(wnd,BFFM_SETSTATUSTEXT,0,LPARAM(@path));
252
253 // gibt´s Dateien mit dem Filter?
254 // nur dann wird der OK-Button des Dialogs aktiviert
255 SendMessage(wnd,BFFM_ENABLEOK,0,LPARAM(CheckFilter(path,fb.FFilter)));
256 end;
257 end;
258 end;
259
260 Result := 0; // von Luckie hinzugefügt, hatte ich vergessen (oops)
261end;
262
263
264constructor TFolderBrowser.Create(Handle: THandle; const Caption: string;
265 const PreSelectedFolder: string = ''; ShowFiles: Boolean = False;
266 NewFolder: Boolean = False);
267begin
268 FHandle := Handle;
269 FCaption := Caption;
270 FInitFolder := PreSelectedFolder;
271 FShowFiles := ShowFiles;
272 FNewFolder := NewFolder;
273 FStatusText := true;
274 FNoTT := true;
275 FFilter := '';
276 FRoot := nil;
277 FTop := 0;
278 FLeft := 0;
279 FPosChanged := false;
280end;
281
282destructor TFolderBrowser.Destroy;
283begin
284 // ggf. belegte "PItemIdList" freigeben
285 if(FRoot <> nil) then
286 self.FreeItemIdList(FRoot);
287
288 inherited Destroy;
289end;
290
291procedure TFolderBrowser.SetTopPosition(const Value: integer);
292begin
293 FPosChanged := true;
294 FTop := Value;
295end;
296
297procedure TFolderBrowser.SetLeftPosition(const Value: integer);
298begin
299 FPosChanged := true;
300 FLeft := Value;
301end;
302
303function TFolderBrowser.SetDefaultRoot: boolean;
304begin
305 // altes Objekt freigeben
306 if(FRoot <> nil) then
307 self.FreeItemIDList(FRoot);
308
309 // und alles zurücksetzen
310 FRoot := nil;
311 Result := true;
312end;
313
314function TFolderBrowser.SetRoot(const SpecialFolderId: integer): boolean;
315begin
316 // altes Objekt freigeben
317 if(FRoot <> nil) then
318 self.FreeItemIDList(FRoot);
319
320 // SpecialFolderId kann eine der CSIDL_*-Konstanten sein,
321 // CSIDL_DESKTOP
322 // CSIDL_STARTMENU
323 // CSIDL_PERSONAL
324 // ...
325 // s. PSDK
326
327 // neuen Root setzen
328 Result := SHGetSpecialFolderLocation(FHandle,SpecialFolderId,FRoot) = S_OK;
329end;
330
331function TFolderBrowser.SetRoot(const Path: string): boolean;
332begin
333 // altes Objekt freigeben
334 if(FRoot <> nil) then
335 self.FreeItemIDList(FRoot);
336
337 // neuen Root setzen
338 Result := SHGetIDListFromPath(Path,FRoot);
339end;
340
341function TFolderBrowser.Execute: Boolean;
342var
343 hr : HRESULT;
344 BrowseInfo : TBrowseInfo;
345 pidlResult : PItemIDList;
346 DisplayName,
347 Path : array[0..MAX_PATH + 1]of char;
348begin
349 Result := false;
350
351 hr := CoInitializeEx(nil,COINIT_APARTMENTTHREADED);
352 // Wenn die COM-Bibliothek noch nicht initialisiert ist,
353 // dann ist das Ergebnis S_OK; ist sie bereits initialisiert
354 // ist sie S_FALSE
355 if(hr = S_OK) or (hr = S_FALSE) then
356 try
357 // "BrowseInfo" mit Werten füllen
358 ZeroMemory(@BrowseInfo,sizeof(BrowseInfo));
359 BrowseInfo.hwndOwner := FHandle;
360 BrowseInfo.pidlRoot := FRoot;
361 BrowseInfo.pszDisplayName := @Displayname;
362 BrowseInfo.lpszTitle := pchar(FCaption);
363 BrowseInfo.lpfn := @FolderCallBack;
364
365 // TFolderBrowser-Klasse als Referenz für Callback-Funktion
366 // übergeben (PL)
367 BrowseInfo.lParam := LPARAM(self);
368
369 // Flags
370 if(FStatusText) then
371 BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_STATUSTEXT;
372
373
374 // BIF_USENEWUI sorgt dafür dass besagter Button immer angezeigt wird,
375 // egal, ob BIF_BROWSEINCLUDEFILES gesetzt wird oder nicht, daher
376 // rausgenommen (Luckie)
377 if(FShowFiles) then
378 BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_BROWSEINCLUDEFILES;
379
380 // Button zum Erstellen neuer Ordner anzeigen? (Luckie, PL)
381 if(FNewFolder) then
382 BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_NEWDIALOGSTYLE
383 else
384 BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_NONEWFOLDERBUTTON;
385
386 // Windows XP sucht automatisch die Verknüpfungsziele von
387 // Shortcuts heraus; soll stattdessen aber der Name der
388 // Verknüpfung angezeigt werden, ist das Flag BIF_NOTRANSLATETARGETS
389 // erforderlich; Sinn macht es nur unter Windows XP
390 if(FNoTT) then
391 BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_NOTRANSLATETARGETS;
392 // für die älteren Windows-Versionen gibt es mit der Funktion
393 // "TranslateLink" (s. weiter unten) eine Entsprechung, um die
394 // Ziele von Shortcuts zu ermitteln (Mathias)
395
396
397 // Dialog aufrufen
398 pidlResult := SHBrowseForFolder(BrowseInfo);
399 if(pidlResult <> nil) then
400 begin
401 if(FSelected = '') then
402 if(SHGetPathFromIdList(pidlResult,Path)) and
403 (Path[0] <> #0) then
404 begin
405 FSelected := Path;
406 Result := true;
407 end;
408
409 self.FreeItemIdList(pidlResult);
410 end;
411 finally
412 CoUninitialize;
413 end;
414end;
415
416function TFolderBrowser.TranslateLink(const LnkFile: string): string;
417var
418 link : IShellLink;
419 hr : HRESULT;
420 afile : IPersistFile;
421 pwcLnkFile : array[0..MAX_PATH]of widechar;
422 szData : array[0..MAX_PATH]of char;
423 FindData : TWin32FindData;
424begin
425 // Standardergebnis
426 Result := '';
427 link := nil;
428 afile := nil;
429
430 hr := CoInitializeEx(nil,COINIT_APARTMENTTHREADED);
431 if(hr = S_OK) or (hr = S_FALSE) then
432 try
433 // IShellLink-Interface erzeugen, ...
434 link := CreateComObject(CLSID_ShellLink,hr) as IShellLink;
435 if(hr = S_OK) and (link <> nil) then
436 begin
437 // ... & Verknüpfung laden
438 StringToWideChar(LnkFile,pwcLnkFile,sizeof(pwcLnkFile));
439 afile := link as IPersistFile;
440
441 if(afile <> nil) and
442 (afile.Load(pwcLnkFile,STGM_READ) = S_OK) then
443 begin
444 ZeroMemory(@szData,sizeof(szData));
445
446 // Pfad + Dateiname ermitteln, ...
447 if(link.GetPath(szData,sizeof(szData),FindData,
448 SLGP_RAWPATH) = S_OK) then
449 begin
450 SetString(Result,szData,lstrlen(szData));
451 // ... & evtl. Umgebungsvariablen filtern
452 Result := ExpandEnvStr(Result);
453 end;
454 end;
455 end;
456 finally
457 if(afile <> nil) then afile := nil;
458 if(link <> nil) then link := nil;
459
460 CoUninitialize;
461 end;
462end;
463
464procedure TFolderBrowser.FreeItemIDList(var pidl: pItemIDList);
465var
466 ppMalloc : iMalloc;
467begin
468 if(SHGetMalloc(ppMalloc) = S_OK) then
469 try
470 ppMalloc.Free(pidl);
471 pidl := nil;
472 finally
473 ppMalloc := nil;
474 end;
475end;
476
477
478const
479 MsiDllName = 'msi.dll';
480
481 INSTALLSTATE_ABSENT = 2; // uninstalled
482 INSTALLSTATE_LOCAL = 3; // installed on local drive
483 INSTALLSTATE_SOURCE = 4; // run from source, CD or net
484 INSTALLSTATE_SOURCEABSENT = -4; // run from source, source is unavailable
485 INSTALLSTATE_NOTUSED = -7; // component disabled
486 INSTALLSTATE_INVALIDARG = -2; // invalid function argument
487 INSTALLSTATE_UNKNOWN = -1; // unrecognized product or feature
488
489type
490 INSTALLSTATE = LongInt;
491
492 TMsiGetShortcutTarget = function(szShortcutTarget, szProductCode,
493 szFeatureId, szComponentCode: PAnsiChar): uint; stdcall;
494 TMsiGetComponentPath = function(szProduct, szComponent: PAnsiChar;
495 lpPathBuf: PAnsiChar; pcchBuf: pdword): INSTALLSTATE; stdcall;
496var
497 MsiGetShortcutTarget : TMsiGetShortcutTarget = nil;
498 MsiGetComponentPath : TMsiGetComponentPath = nil;
499 MsiDll : dword = 0;
500
501function TFolderBrowser.TranslateMsiLink(const LnkFile: string): string;
502var
503 ProductCode,
504 FeatureId,
505 ComponentCode : array[0..MAX_PATH]of char;
506 Path : array[0..MAX_PATH]of char;
507 PathLen : dword;
508begin
509 Result := '';
510 if(@MsiGetShortcutTarget = nil) or (@MsiGetComponentPath = nil) then exit;
511
512 ZeroMemory(@ProductCode, sizeof(ProductCode));
513 ZeroMemory(@FeatureId, sizeof(FeatureId));
514 ZeroMemory(@ComponentCode, sizeof(ComponentCode));
515
516 if(MsiGetShortcutTarget(PAnsiChar(LnkFile), ProductCode, FeatureId,
517 ComponentCode) = ERROR_SUCCESS) then
518 begin
519 ZeroMemory(@Path, sizeof(Path));
520 PathLen := sizeof(Path);
521
522 case MsiGetComponentPath(ProductCode, ComponentCode, Path, @PathLen) of
523 INSTALLSTATE_LOCAL,
524 INSTALLSTATE_SOURCE:
525 SetString(Result, Path, lstrlen(Path));
526 end;
527 end;
528end;
529
530
531initialization
532 MsiDll := GetModuleHandle(MsiDllName);
533 if(MsiDll = 0) then MsiDll := LoadLibrary(MsiDllName);
534
535 if(MsiDll <> 0) then
536 begin
537 MsiGetShortcutTarget := GetProcAddress(MsiDll, 'MsiGetShortcutTargetA');
538 MsiGetComponentPath := GetProcAddress(MsiDll, 'MsiGetComponentPathA');
539
540 if(@MsiGetShortcutTarget = nil) or
541 (@MsiGetComponentPath = nil) then
542 begin
543 FreeLibrary(MsiDll);
544 MsiDll := 0;
545 end;
546 end;
547finalization
548 if(MsiDll <> 0) then FreeLibrary(MsiDll);
549end.
Note: See TracBrowser for help on using the repository browser.