1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:

function GetFolder(const ARoot: integer; const ACaption: String): String;
var
  bi: TBROWSEINFO;
  lpBuffer: PChar;
  pidlPrograms,
  pidlBrowse: PItemIDList;
  ShellH: IMalloc;
begin
  if (not SUCCEEDED(SHGetSpecialFolderLocation(GetActiveWindow,
                                               ARoot,
                                               pidlPrograms))) then
    Exit;
  try
    GetMem(lpBuffer, MAX_PATH);
    try
      bi.hwndOwner:=GetActiveWindow;
      bi.pidlRoot:=pidlPrograms;
      bi.pszDisplayName:=lpBuffer;
      bi.lpszTitle:=PChar(ACaption);
      bi.ulFlags:=BIF_RETURNONLYFSDIRS;
      bi.lpfn:=NIL;
      bi.lParam:=0;
      pidlBrowse:=SHBrowseForFolder(bi);

      if (pidlBrowse <> nil) and (SHGetPathFromIDList(pidlBrowse,
                                                      lpBuffer)) then
        Result:=lpBuffer;
    finally
      FreeMem(lpBuffer);
    end;
  finally
    if SHGetMalloc(ShellH) = NOERROR then
       ShellH.Free(pidlBrowse);
  end;
end;                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:

uses  
  ShlObj, ActiveX;  

 
function AdvSelectDirectory(const Caption: string; const Root: WideString;  
  var Directory: string; EditBox: Boolean = False; ShowFiles: Boolean = False;  
  AllowCreateDirs: Boolean = True): Boolean;  
  

 
  function SelectDirCB(Wnd: HWND; uMsg: UINT; lParam, lpData: lParam): Integer;  
    stdcall;  
  var  
    PathName: array[0..MAX_PATH] of Char;  
  begin  
    case uMsg of  
      BFFM_INITIALIZED: SendMessage(Wnd, BFFM_SETSELECTION, Ord(True), Integer(lpData));  
     
      {BFFM_SELCHANGED:  
      begin  
        SHGetPathFromIDList(PItemIDList(lParam), @PathName);  
        
      end;}  
    end;  
    Result := 0;  
  end; 

 
var  
  WindowList: Pointer;  
  BrowseInfo: TBrowseInfo;  
  Buffer: PChar;  
  RootItemIDList, ItemIDList: PItemIDList;  
  ShellMalloc: IMalloc;  
  IDesktopFolder: IShellFolder;  
  Eaten, Flags: LongWord;  
const  
  
  BIF_USENEWUI = $0040;  
  BIF_NOCREATEDIRS = $0200;  
begin  
  Result := False;  
  if not DirectoryExists(Directory) then  
    Directory := '';  
  FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);  
  if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then  
  begin  
    Buffer := ShellMalloc.Alloc(MAX_PATH);  
    try  
      RootItemIDList := nil;  
      if Root <> '' then  
      begin  
        SHGetDesktopFolder(IDesktopFolder);  
        IDesktopFolder.ParseDisplayName(Application.Handle, nil,  
          POleStr(Root), Eaten, RootItemIDList, Flags);  
      end;  
      OleInitialize(nil);  
      with BrowseInfo do  
      begin  
        hwndOwner := Application.Handle;  
        pidlRoot := RootItemIDList;  
        pszDisplayName := Buffer;  
        lpszTitle := PChar(Caption);  
       
        ulFlags := BIF_RETURNONLYFSDIRS or BIF_USENEWUI or  
          BIF_EDITBOX * Ord(EditBox) or BIF_BROWSEINCLUDEFILES * Ord(ShowFiles) or  
          BIF_NOCREATEDIRS * Ord(not AllowCreateDirs);  
        lpfn    := @SelectDirCB;  
        if Directory <> '' then  
          lParam := Integer(PChar(Directory));  
      end;  
      WindowList := DisableTaskWindows(0);  
      try  
        ItemIDList := ShBrowseForFolder(BrowseInfo);  
      finally  
        EnableTaskWindows(WindowList);  
      end;  
      Result := ItemIDList <> nil;  
      if Result then  
      begin  
        ShGetPathFromIDList(ItemIDList, Buffer);  
        ShellMalloc.Free(ItemIDList);  
        Directory := Buffer;  
      end;  
    finally  
      ShellMalloc.Free(Buffer);  
    end;  
  end;  
end;  

 

 
// Example:  
procedure TForm1.Button1Click(Sender: TObject);  
var  
  dir: string;  
begin  
  AdvSelectDirectory('Caption', 'c:\', dir, False, False, True);  
  Label1.Caption := dir;  
end;  

// Function zum Positionieren

  function SelectDirCB(Wnd: HWND; uMsg: UINT; lParam, lpData: lParam): Integer;  
    stdcall;  
  var  
    PathName: array[0..MAX_PATH] of Char;  
  begin  
    case uMsg of  
      BFFM_INITIALIZED:  
      begin  
        SendMessage(Wnd, BFFM_SETSELECTION, Ord(True), Integer(lpData));  
        SetWindowPos(Wnd, 0, 20, 20, 0, 0, SWP_NOSIZE or SWP_SHOWWINDOW);  
      end;  
    end;  
    Result := 0;  
  end;