Форум: "Основная";
Текущий архив: 2004.08.22;
Скачать: [xml.tar.bz2];

Вниз

диалог выбора директории   Найти похожие ветки 

← →
dizrov   (2004-08-06 15:26) [0]

подскажите плз. как программно создать нормальный диалог выбора директории!лучше с исходником.
Заранее спасибо!

---

← →
s999   (2004-08-06 15:30) [1]

В чем ненормальность стандартных?

---

← →
BillyJeans   (2004-08-06 15:33) [2]

чиста нармалный такой диалог ;)

---

← →
Rouse_ ©   (2004-08-06 15:34) [3]

////////////////////////////////////////////////////////////////////////////////
//
// Fangorn Wizards Lab Extension Library v1.35
// © Fangorn Wizards Lab 1998 - 2003
// Автор: Александр (Rouse_) Багель
//

// Последние изменения:
// 20 марта 2003 - отключен модуль ShlOBJ,
// из-за которого возникали проблемы совместимости
// различных версий Delphi

// Известные проблемы:
// Отсутствуют

unit FWOpenDirectory;

interface

uses
 Windows, Classes, Controls, FWUtils, {$IFDEF VER130} DsgnIntf
 {$ELSE} DesignIntf {$ENDIF};

type
 PSHItemID = ^TSHItemID;
 _SHITEMID = record
   cb: Word;
   abID: array[0..0] of Byte;
 end;
 TSHItemID = _SHITEMID;

 PItemIDList = ^TItemIDList;
 _ITEMIDLIST = record
    mkid: TSHItemID;
  end;
 TItemIDList = _ITEMIDLIST;

 BFFCALLBACK = function(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer stdcall;
 TFNBFFCallBack = type BFFCALLBACK;

 _browseinfoA = record
   hwndOwner: HWND;
   pidlRoot: PItemIDList;
   pszDisplayName: PAnsiChar;
   lpszTitle: PAnsiChar;
   ulFlags: UINT;
   lpfn: TFNBFFCallBack;
   lParam: LPARAM;          
   iImage: Integer;
 end;
 TBrowseInfoA = _browseinfoA;
 TBrowseInfo = TBrowseInfoA;

 TFWOpenDirStyle = (odsReturnOnlyFSDirs, odsDontGoBelowDomain, odsStatusText,
   odsReturnFSAncestors, odsEditBox, odsValidate, odsNewDialogStyle,
   odsBrowseIncludeUrls, odsBrowseForComputer, odsBrowseForPrinter,
   odsBrowseIncludeFiles, odsShareable, odsUseNewUI);
 TFWOpenDirStyles = set of TFWOpenDirStyle;

 TFWOpenDirectory = class(TComponent)
 private
   FAbout: String;
   FTitle: String;
   FDirName: String;
   FStyle: TFWOpenDirStyles;
   FStyleArray: array [0..12] of Integer;
   FHandle: THandle;
 protected
   procedure Init; virtual;
 public
   constructor Create(AOwner: TComponent); override;
   function Execute: Boolean;
   property DirName: String read FDirName;
 published
   property About: String read FAbout write FAbout;
   property Title: String read FTitle write FTitle;
   property Style: TFWOpenDirStyles read FStyle write FStyle default [odsReturnOnlyFSDirs];
 end;

const
 BIF_RETURNONLYFSDIRS   = $0001;  
 BIF_DONTGOBELOWDOMAIN  = $0002;  
 BIF_STATUSTEXT         = $0004;
 BIF_RETURNFSANCESTORS  = $0008;
 BIF_EDITBOX            = $0010;
 BIF_VALIDATE           = $0020;  
 BIF_NEWDIALOGSTYLE     = $0040;
 BIF_BROWSEINCLUDEURLS  = $0080;
 BIF_BROWSEFORCOMPUTER  = $1000;  
 BIF_BROWSEFORPRINTER   = $2000;  
 BIF_BROWSEINCLUDEFILES = $4000;
 BIF_SHAREABLE          = $8000;
 BIF_USENEWUI = BIF_NEWDIALOGSTYLE or BIF_EDITBOX;

 function SHBrowseForFolder(var lpbi: TBrowseInfo): PItemIDList; stdcall;
 function SHGetPathFromIDList(pidl: PItemIDList; pszPath: PChar): BOOL; stdcall;
 function SHBrowseForFolder; external "shell32.dll" name "SHBrowseForFolderA";
 function SHGetPathFromIDList; external "shell32.dll" name "SHGetPathFromIDListA";
 procedure Register;
 
implementation

procedure Register;
begin
 RegisterComponents("Fangorn Wizards Lab", [TFWOpenDirectory]);
 RegisterPropertyEditor(TypeInfo(String), TFWOpenDirectory, "About", TAboutPropertyEditor);
end;

{ TFWOpenDirectory }

constructor TFWOpenDirectory.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 FHandle := TWinControl(AOwner).Handle;
 FStyle := [odsReturnOnlyFSDirs];
 Init;
end;

function TFWOpenDirectory.Execute: Boolean;
var
 lpItemID: PItemIDList;
 BrowseInfo: TBrowseInfo;
 DisplayName: array[0..MAX_PATH] of Char;
 TempPath: array[0..MAX_PATH] of Char;
 I, Flags: Integer;
begin
 TempPath[0] := #0;
 FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);
 BrowseInfo.hwndOwner := FHandle;
 BrowseInfo.pszDisplayName := @DisplayName;
 BrowseInfo.lpszTitle := PAnsiChar(FTitle);

 Flags := 0;
 for I:= 0 to 12 do
   if (TFWOpenDirStyle(I) in FStyle) then
    Flags:= Flags or FStyleArray[I];
 BrowseInfo.ulFlags := Flags;
 lpItemID := SHBrowseForFolder(BrowseInfo);
 if Assigned(lpItemId) then
 begin
   Result := True;
   SHGetPathFromIDList(lpItemID, TempPath);
   GlobalFreePtr(lpItemID);
 end
 else
   Result := False;
 FDirName := String(TempPath);
end;

procedure TFWOpenDirectory.Init;
begin
 FStyleArray[0] := BIF_RETURNONLYFSDIRS;
 FStyleArray[1] := BIF_DONTGOBELOWDOMAIN;
 FStyleArray[2] := BIF_STATUSTEXT;
 FStyleArray[3] := BIF_RETURNFSANCESTORS;
 FStyleArray[4] := BIF_EDITBOX;
 FStyleArray[5] := BIF_VALIDATE;
 FStyleArray[6] := BIF_NEWDIALOGSTYLE;
 FStyleArray[7] := BIF_BROWSEINCLUDEURLS;
 FStyleArray[8] := BIF_BROWSEFORCOMPUTER;
 FStyleArray[9] := BIF_BROWSEFORPRINTER;
 FStyleArray[10] := BIF_BROWSEINCLUDEFILES ;
 FStyleArray[11] := BIF_SHAREABLE;
 FStyleArray[12] := BIF_USENEWUI;
end;

end.

---

← →
dizrov   (2004-08-06 15:35) [4]

насчет ненормальности я погорячился
скажем так - нужно показать диалог выбора дир-и

---

← →
dizrov   (2004-08-06 15:35) [5]

Удалено модератором
Примечание: Дубль...

---

← →
dizrov   (2004-08-06 15:37) [6]

Удалено модератором
Примечание: Дубль...

---

← →
dizrov   (2004-08-06 15:37) [7]

я че-нить попроще есть?

---

← →
begin...end ©   (2004-08-06 15:37) [8]

SelectDirectory() ?

---

← →
Anatoly Podgoretsky ©   (2004-08-06 15:42) [9]

begin...end ©   (06.08.04 15:37) [8]
Пойдет, раз он снял ненормальное требование о нормальности.

---

Страницы: 1 вся ветка

Форум: "Основная";
Текущий архив: 2004.08.22;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.47 MB
Время: 0.04 c