FAQ VCL
Диалоги

:: Меню ::
:: На главную ::
:: FAQ ::
:: Заметки ::
:: Практика ::
:: Win API ::
:: Проекты ::
:: Скачать ::
:: Секреты ::
:: Ссылки ::

:: Сервис ::
:: Написать ::

:: MVP ::

:: RSS ::

Яндекс.Метрика

Как вызвать диалог выбора каталога?

// Способ первый
uses
  {...,} FileCtrl;

procedure TForm1.Button1Click(Sender: TObject);
const
  SELDIRHELP = 1000;
var
  Dir: string;
begin
   Dir := 'c:\';
   SelectDirectory( Dir, [sdAllowCreate, sdPerformCreate, sdPrompt], SELDIRHELP );
end;

// Способ второй
uses
  {...,} FileCtrl;

procedure TForm1.Button1Click(Sender: TObject);
var
  Dir1: string; // Dir1 - начальная директория (выше нее подняться нельзя)
  Dir2: string; // Dir2 - выбранный каталог (если передать реальный путь, он будет открыт в диалоге)
begin
   if SelectDirectory( 'Выбор каталога', Dir1, Dir2 ) then
      {...} // Каталог выбран
end;

// Способ третий
// Для вывода диалога "Обзор папок" существует функция SHBrowseForFolder. 
// Для выбора того, какие папки будут выведены в диалоге, 
// используется функция SHGetSpecialFolderLocation. 
// В этом примере выводится рабочий стол со всеми подпапками 
// (папки рабочего стола, Мой компьютер, Корзина). 
// Для выбора папки в меню пуск используется CSIDL_STARTMENU вместо CSIDL_DESKTOP.
uses
  {...,} ShlObj;

implementation

procedure CallBack(wnd: hWnd; uMsg: UINT; lParam, lpData: LParam) stdcall;
begin
  SendMessage( wnd, BFFM_ENABLEOK, 0, 1 );
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  bi: TBrowseInfo;
  s: PChar;
  PIDL, ResPIDL: PItemIDList;
begin
   SHGetSpecialFolderLocation( Handle, CSIDL_DESKTOP, PIDL );
   s := StrAlloc( 128 );
   bi.hwndOwner := Handle;
   bi.pszDisplayName := s;
   bi.lpszTitle := 'Выбор прапки';
   bi.pidlRoot := PIDL;
   bi.lpfn := addr( CallBack );
   ResPidl := SHBrowseForFolder( bi );
   SHGetPathFromIDList( ResPidl, s );
   Caption := s;
end;

// Способ четвертый
uses
  {...,} ShellAPI, ShlObj;

function TForm1.ShowBrowseFolderForm(Title: string): string;
var
  bi: TBrowseInfo;
  pidlBrowse: PItemIDList;
  Buffer: array[0..255] of char;
  dispname: array[0..MAX_PATH] of char;
begin
   bi.hwndOwner := Application.Handle;
   bi.pidlRoot := nil;
   bi.pszDisplayName := dispname;
   bi.lpszTitle := PChar( Title );
   bi.ulFlags := BIF_RETURNONLYFSDIRS;
   bi.lpfn := nil;
   bi.lParam := 0;
   bi.iImage := 0;
   pidlBrowse := SHBrowseForFolder( bi );
   if ( pidlBrowse <> nil ) then
      if ( SHGetPathFromIDList( pidlBrowse, @Buffer ) ) then
      result := StrPas( @Buffer );
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   Form1.Caption := ShowBrowseFolderForm( 'Выберите папку' );
end;

// Способ пятый
uses
  {...,} ShellAPI, ShlObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  TitleName: string;
  lpItemID: PItemIDList;
  BrowseInfo: TBrowseInfo;
  DisplayName: array[0..MAX_PATH] of char;
  TempPath: array[0..MAX_PATH] of char;
begin
   FillChar( BrowseInfo, SizeOf( TBrowseInfo ), #0 );
   BrowseInfo.hwndOwner := Form1.Handle;
   BrowseInfo.pszDisplayName := @DisplayName;
   TitleName := 'Выберите каталог';
   BrowseInfo.lpszTitle := PChar( TitleName );
   BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;
   lpItemID := SHBrowseForFolder( BrowseInfo );
   if lpItemId <> nil then
   begin
      SHGetPathFromIDList( lpItemID, TempPath );
      Caption := TempPath;
      GlobalFreePtr( lpItemID );
   end;
end;


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

// Способ первый
uses
  {...,} ActiveX, ShlObj;

var
  Form1: TForm1;
  myDir: string;

implementation

function BrowseCallbackProc(hwnd: HWND; uMsg: UINT; lParam: LPARAM; lpData: LPARAM): integer; stdcall;
begin
   Result := 0;
   if uMsg = BFFM_INITIALIZED then
      SendMessage( hwnd, BFFM_SETSELECTION, 1, LongInt( PChar( myDir ) ) );
end;

function TForm1.SelectDirPlus(hWnd: HWND; const Caption: string;
  const Root: WideString): String;
var
  WindowList: Pointer;
  BrowseInfo : TBrowseInfo;
  Buffer: PChar;
  RootItemIDList, ItemIDList: PItemIDList;
  ShellMalloc: IMalloc;
  IDesktopFolder: IShellFolder;
  Eaten, Flags: LongWord;
  Cmd: Boolean;
begin
   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( hWnd, nil,
            POleStr( Root ), Eaten, RootItemIDList, Flags );
         end;
         with BrowseInfo do
         begin
            hwndOwner := hWnd;
            pidlRoot := RootItemIDList;
            pszDisplayName := Buffer;
            lpfn := @BrowseCallbackProc;
            lpszTitle := PChar( Caption );
            ulFlags := BIF_RETURNONLYFSDIRS or $0040 or BIF_EDITBOX or BIF_STATUSTEXT;
         end;
         WindowList := DisableTaskWindows( 0 );
         try
           ItemIDList := ShBrowseForFolder( BrowseInfo );
         finally
            EnableTaskWindows( WindowList );
         end;
         Cmd :=  ItemIDList <> nil;
         if Cmd then
         begin
            ShGetPathFromIDList( ItemIDList, Buffer );
            ShellMalloc.Free( ItemIDList );
            Result:= Buffer;
         end;
      finally
         ShellMalloc.Free( Buffer );
      end;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   Form1.Caption := SelectDirPlus( Handle, 'Выберите каталог', '' )
end;

// Способ второй
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 );
           // 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
  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;

procedure TForm1.Button1Click(Sender: TObject);
var
  dir: string;
begin
   AdvSelectDirectory( 'Caption', 'c:\', dir, false, false, true );
   Caption := dir;
end;


Как вызвать диалог сетевого окружения?

// Способ первый
uses
  {...,} ShlObj;

function TForm1.GetComputerNetName: string;
var
  RootItemIDList: PItemIDList;
  BrowseInfo: TBrowseInfo;
  Buffer: PChar;
begin
   Result := '';
   if not( SHGetSpecialFolderLocation( 0, CSIDL_NETWORK, RootItemIDList ) = NO_ERROR ) then Exit;
   GetMem( Buffer, Max_Path );
   FillChar( BrowseInfo, SizeOf( BrowseInfo ), 0 );
   with BrowseInfo do
   begin
      hwndOwner := Application.Handle;
      pidlRoot := RootItemIDList;
      pszDisplayName := Buffer;
      lpszTitle := 'Подключенные компьютеры';
      ulFlags := BIF_BROWSEFORCOMPUTER;
   end;
   if SHBrowseForFolder( BrowseInfo ) = nil then Exit;
   Result := string( Buffer );
   FreeMem( Buffer );
end;

// Способ второй
uses
  {...,} ShlObj, ActiveX;

function BrowseComputer( DialogTitle: string; var CompName: string;
                         bNewStyle: boolean ): boolean;
const
  BIF_USENEWUI = 28;
var
  BrowseInfo: TBrowseInfo;
  ItemIDList: PItemIDList;
  ComputerName: array[0..MAX_PATH] of Char;
  Title: string;
  WindowList: Pointer;
  ShellMalloc: IMalloc;
begin
   if Failed( SHGetSpecialFolderLocation( Application.Handle, CSIDL_NETWORK, ItemIDList ) ) then
      raise Exception.Create( 'Unable open browse computer dialog' );
   try
      FillChar( BrowseInfo, SizeOf( BrowseInfo ), 0 );
      BrowseInfo.hwndOwner := Application.Handle;
      BrowseInfo.pidlRoot := ItemIDList;
      BrowseInfo.pszDisplayName := ComputerName;
      Title := DialogTitle;
      BrowseInfo.lpszTitle := PChar( Pointer( Title ) );
      if bNewStyle then
         BrowseInfo.ulFlags := BIF_BROWSEFORCOMPUTER or BIF_USENEWUI
      else
         BrowseInfo.ulFlags := BIF_BROWSEFORCOMPUTER;
      WindowList := DisableTaskWindows( 0 );
      try
         Result := SHBrowseForFolder( BrowseInfo ) <> nil;
      finally
         EnableTaskWindows( WindowList );
      end;
      if Result then CompName := ComputerName;
   finally
      if Succeeded( SHGetMalloc( ShellMalloc ) ) then
         ShellMalloc.Free( ItemIDList );
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Computer: string;
begin
   BrowseComputer( 'Выберите компьютер', Computer, true );
   Caption := Computer;
end;


Как вызвать диалог форматирования дисков?

uses
  {...,} ShellAPI;

function SHFormatDrive( hWnd: HWND; Drive: Word; fmtID: Word;
                        Options: Word ): Longint; stdcall;
external 'Shell32.dll' name 'SHFormatDrive';

procedure TForm1.FormatDrive(Drive: char);
const
  SHFMT_ID_DEFAULT = $FFFF;

  // Быстрое (очистка оглавления диска)
  SHFMT_OPT_QUICKFORMAT = 0;
  // Полное
  SHFMT_OPT_FULLFORMAT = 1;
  // Только копирование системных файлов
  SHFMT_OPT_SYSONLY = 2;

  SHFMT_ERROR = -1;
  SHFMT_CANCEL = -2;
  SHFMT_NOFORMAT = -3;
var
  FmtRes: longint;
  FmtDrive: word;
begin
   FmtDrive := Ord( UpCase( Drive ) ) - 65;
   try
      FmtRes:= ShFormatDrive( Handle,
                              FmtDrive,
                              SHFMT_ID_DEFAULT,
                              SHFMT_OPT_QUICKFORMAT );
      case FmtRes of
         SHFMT_ERROR: ShowMessage( 'Error formatting the drive' );
         SHFMT_CANCEL: ShowMessage( 'User canceled formatting the drive' );
         SHFMT_NOFORMAT: ShowMessage( 'No Format' )
         else
            ShowMessage( 'Disk has been formatted' );
      end;
   except
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   FormatDrive( 'A' );
end;


Как вызвать диалог выбора домена?

// Способ первый
  function SystemFocusDialog( hwndOwner: HWND; dwSelectionFlag: UINT;
    wszName: PWideChar; dwBufSize: DWORD; var bOKPressed: boolean;
    wszHelpFile: PWideChar; dwContextHelpId: DWORD ): DWORD; stdcall;
    external 'ntlanman.dll' Name 'I_SystemFocusDialog';

const
   FOCUSDLG_DOMAINS_ONLY = 1;
   FOCUSDLG_SERVERS_ONLY = 2;
   FOCUSDLG_SERVERS_DOMAINS = 3;
   FOCUSDLG_BROWSE_LOGON_DOMAIN = $00010000;
   FOCUSDLG_BROWSE_WKSTA_DOMAIN = $00020000;
   FOCUSDLG_BROWSE_OTHER_DOMAINS = $00040000;
   FOCUSDLG_BROWSE_TRUSTING_DOMAINS = $00080000;
   FOCUSDLG_BROWSE_WORKGROUP_DOMAINS = $00100000;
   FOCUSDLG_BROWSE_ALL_DOMAINS = FOCUSDLG_BROWSE_LOGON_DOMAIN or
     FOCUSDLG_BROWSE_WKSTA_DOMAIN or FOCUSDLG_BROWSE_OTHER_DOMAINS or
     FOCUSDLG_BROWSE_TRUSTING_DOMAINS or FOCUSDLG_BROWSE_WORKGROUP_DOMAINS;

function ComputerBrowser( hWndParent: HWND; wCompName: PWideChar; dwBufLen: DWORD ): boolean;
var
  dwError: DWORD;
begin
   Result := false;
   dwError := SystemFocusDialog( hWndParent, FOCUSDLG_SERVERS_DOMAINS or FOCUSDLG_BROWSE_ALL_DOMAINS,
                                 wCompName, dwBufLen, Result, nil, 0 );
   if dwError <> NO_ERROR then Exit;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  wCompName: array [0..MAX_COMPUTERNAME_LENGTH + 1] of WideChar;
begin
   if ComputerBrowser( 0, wCompName, MAX_COMPUTERNAME_LENGTH + 1 ) then
      ShowMessage( wCompName )
   else
      ShowMessage( 'no computer selected' );
end;

// Способ второй
type
   TServerBrowseDialogA0 = function( hwnd: HWND; pchBuffer: Pointer;
     cchBufSize: DWORD ): bool; stdcall;

function ShowServerDialog(AHandle: THandle): string;
var
  ServerBrowseDialogA0: TServerBrowseDialogA0;
  LANMAN_DLL: DWORD;
  buffer: array[0..1024] of char;
  bLoadLib: boolean;
begin
   LANMAN_DLL := GetModuleHandle( 'NTLANMAN.DLL' );
   if LANMAN_DLL = 0 then
   begin
      LANMAN_DLL := LoadLibrary( 'NTLANMAN.DLL' );
      bLoadLib := true;
   end;
   if LANMAN_DLL <> 0 then
   begin
      @ServerBrowseDialogA0 := GetProcAddress( LANMAN_DLL, 'ServerBrowseDialogA0' );
      DialogBox( HInstance, MAKEINTRESOURCE( 101 ), AHandle, nil );
      ServerBrowseDialogA0( AHandle, @buffer, 1024 );
      if buffer[0] = '\' then
         Result := buffer;
      if bLoadLib then
         FreeLibrary( LANMAN_DLL );
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   Caption := ShowServerDialog( Handle );
end;


Как отцентрировать информационный диалог (MessageDlg) относительно формы?

uses
  {...,} Consts;

function MessageDlgCtr(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; HelpCtx: Longint): integer;
begin
   with CreateMessageDialog( Msg, DlgType, Buttons ) do
   try
      HelpContext := HelpCtx;
      Left := Screen.ActiveForm.Left + ( Screen.ActiveForm.Width div 2 ) - ( Width div 2 );
      Top := Screen.ActiveForm.Top + ( Screen.ActiveForm.Height div 2 ) - ( Height div 2 );
      Result := ShowModal;
   finally
      Free;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   MessageDlgCtr( 'Центрированный диалог', mtInformation, [mbOk], 0 );
end;


Как показать диалог организации избранных документов?

uses
  {...,} SHDocVw, ShlObj, ShellAPI;

function OrganizeFavorite( h: THandle; path: PChar ): boolean;
   stdcall external 'shdocvw.dll' name 'DoOrganizeFavDlg';

implementation

function GetSpecialFolderPath( CallerHandle: THandle; CSIDL: Integer ): PChar;
var
  exInfo: TShellExecuteInfo;
  Buf: PChar;
begin
   FillChar( exInfo, SizeOf( exInfo ), 0 );
   with exInfo do
   begin
      cbSize := SizeOf( exInfo );
      fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_IDLIST;
      Wnd := CallerHandle;
      nShow := SW_SHOWNORMAL;
      Buf := StrAlloc(MAX_PATH);
      SHGetSpecialFolderPath( Wnd, Buf, CSIDL, true );
      Result := Buf;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   OrganizeFavorite( Handle, GetSpecialFolderPath( Handle, CSIDL_FAVORITES ) );
end;


Как показать диалог для запуска приложения?

// Способ первый
uses
  {...,} ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  ShellApplication: Variant;
begin
   ShellApplication := CreateOleObject( 'Shell.Application' );
   ShellApplication.FileRun;
end;

// Способ второй
  // For Win NT
  procedure RunFileDlgW( OwnerWnd: HWND; Icon: HICON; lpstrDirectory: PWideChar;
    lpstrTitle: PWideChar; lpstrDescription: PWideChar; Flags: Longint ); stdcall;
    external 'Shell32.dll' Index 61;
  // For Win 9x (Win NT to show standard captions)
  procedure RunFileDlg( OwnerWnd: HWND; Icon: HICON; lpstrDirectory: PChar;
    lpstrTitle: PChar; lpstrDescription: PChar; Flags: Longint ); stdcall;
    external 'Shell32.dll' Index 61;

const
  RFF_NOBROWSE = 1; //Removes the browse button.
  RFF_NODEFAULT = 2; // No default item selected.
  RFF_CALCDIRECTORY = 4; // Calculates the working directory from the file name.
  RFF_NOLABEL = 8; // Removes the edit box label.
  RFF_NOSEPARATEMEM = 14; // Removes the Separate Memory Space check box (Windows NT only).

function ShowRunFileDialg( OwnerWnd: HWND; InitialDir, Title, Description: PChar;
   flags: Integer; StandardCaptions: boolean ): boolean;
var
  HideBrowseButton: boolean;
  TitleWideChar, InitialDirWideChar, DescriptionWideChar: PWideChar;
  Size: Integer;
begin
   if ( Win32Platform = VER_PLATFORM_WIN32_NT ) and not StandardCaptions then
   begin
      Size := SizeOf( WideChar ) * MAX_PATH;
      InitialDirWideChar := nil;
      TitleWideChar := nil;
      DescriptionWideChar := nil;
      GetMem( InitialDirWideChar, Size );
      GetMem( TitleWideChar, Size );
      GetMem( DescriptionWideChar, Size );
      StringToWideChar( InitialDir, InitialDirWideChar, MAX_PATH );
      StringToWideChar( Title, TitleWideChar, MAX_PATH );
      StringToWideChar( Description, DescriptionWideChar, MAX_PATH );
      try
         RunFileDlgW( OwnerWnd, 0, InitialDirWideChar, TitleWideChar, DescriptionWideChar, Flags );
      finally
         FreeMem( InitialDirWideChar );
         FreeMem( TitleWideChar );
         FreeMem( DescriptionWideChar );
      end;
   end
   else
      RunFileDlg( OwnerWnd, 0, PChar( InitialDir ), PChar( Title ), PChar( Description ), Flags );
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShowRunFileDialg( FindWindow( 'Shell_TrayWnd', nil ), nil, nil, nil, RFF_NOBROWSE, true );
end;


Как открыть диалог смены системного времени?

uses
  {...,} ShellAPI;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShellExecute( Handle, 'open', 'control', 'date/time', nil, SW_SHOW );
end;


Как открыть диалог "Мастер установки принтера"?

uses
  {...,} ShellAPI;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShellExecute( Handle, nil, 'rundll32.exe',
      'shell32.dll,SHHelpShortcuts_RunDLL AddPrinter', '', SW_SHOWNORMAL );
end;

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