Программирование на Delphi

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;

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