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

Last change on this file since 92 was 90, checked in by alloc, 15 years ago
File size: 16.8 KB
Line 
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.