Показать диалог выбора директории с кнопкой для создания новой

Оформил: DeeCo

{....}

 uses
   ShlObj, ActiveX;

 {....}


 { 
  This code shows the SelectDirectory dialog with additional expansions: 
  - an edit box, where the user can type the path name, 
  - also files can appear in the list, 
  - a button to create new directories. 


  Dieser Code zeigt den SelectDirectory-Dialog mit zusatzlichen Erweiterungen: 
  - eine Edit-Box, wo der Benutzer den Verzeichnisnamen eingeben kann, 
  - auch Dateien konnen in der Liste angezeigt werden, 
  - eine Schaltflache zum Erstellen neuer Verzeichnisse. 
}

 function AdvSelectDirectory(const Caption: string; const Root: WideString;
   var Directory: string; EditBox: Boolean = False; ShowFiles: Boolean = False;
   AllowCreateDirs: Boolean = True): Boolean;
   // callback function that is called when the dialog has been initialized 
  //or a new directory has been selected 

  // Callback-Funktion, die aufgerufen wird, wenn der Dialog initialisiert oder 
  //ein neues Verzeichnis selektiert wurde 
  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));
       // include the following comment into your code if you want to react on the 
      //event that is called when a new directory has been selected 
      // binde den folgenden Kommentar in deinen Code ein, wenn du auf das Ereignis 
      //reagieren willst, das aufgerufen wird, wenn ein neues Verzeichnis selektiert wurde 
      {BFFM_SELCHANGED: 
      begin 
        SHGetPathFromIDList(PItemIDList(lParam), @PathName); 
        // the directory "PathName" has been selected 
        // das Verzeichnis "PathName" wurde selektiert 
      end;}
     end;
     Result := 0;
   end;
 var
   WindowList: Pointer;
   BrowseInfo: TBrowseInfo;
   Buffer: PChar;
   RootItemIDList, ItemIDList: PItemIDList;
   ShellMalloc: IMalloc;
   IDesktopFolder: IShellFolder;
   Eaten, Flags: LongWord;
 const
   // necessary for some of the additional expansions 
  // notwendig fur einige der zusatzlichen Erweiterungen 
  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);
         // defines how the dialog will appear: 
        // legt fest, wie der Dialog erscheint: 
        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;