Тема: VBA. КАК ВЫБРАТЬ ДИРЕКТОРИЮ
Есть компонент commonDialog, но он позвроляет выбирать только файлы.
А нужно выбрать директорию. Как это можно сделать на VBA??
Информационный портал для профессионалов в области САПР
Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
VBA. КАК ВЫБРАТЬ ДИРЕКТОРИЮ
Форумы CADUser → Программирование → VBA → VBA. КАК ВЫБРАТЬ ДИРЕКТОРИЮ
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Сообщения 5
Re: VBA. КАК ВЫБРАТЬ ДИРЕКТОРИЮ
Вот так:
Option Explicit
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long
Private Const BIF_RETURNONLYFSDIRS = &H1
Sub ConnectX()
Dim MyPath As String, FName As String
MyPath = GetFolder("Choose Folder") ' Выбор папки с файлами *.dwg
FName = Dir(MyPath & "\*.dwg", vbNormal) ' Возвращает первый элемент.
Do While FName <> "" ' Начинает цикл.
Loop
End Sub
Public Function GetFolder(szDialogTitle As String) As String
Dim X As Long, bi As BROWSEINFO, dwIList As Long
Dim szPath As String, wPos As Integer
With bi
.lpszTitle = szDialogTitle
.ulFlags = BIF_RETURNONLYFSDIRS
End With
dwIList = SHBrowseForFolder(bi)
szPath = Space$(512)
X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
If X Then
wPos = InStr(szPath, Chr(0))
GetFolder = Left$(szPath, wPos - 1)
Else
GetFolder = ""
End If
End Function
- Leonid
- Восстановленный участник
Re: VBA. КАК ВЫБРАТЬ ДИРЕКТОРИЮ
> killem
Здорово работает ваш код, я хоть и не разобрался пока до конца, но получил удовольствие.Спасибо.
И кстати, на подскажите ли, где можно обновить библиотеку API-функций для VB?
- Миша
- Восстановленный участник
Re: VBA. КАК ВЫБРАТЬ ДИРЕКТОРИЮ
Подскажите пожалуйста! Как можно изменять размеры окна выбора директории и при открытии надо чтобы указывалось в развёрнутом виде дерево папок до нужной директории. Как это сделать?
У меня есть пример на Delphi как это можно сделать:
{------------------------------------------------------------------------
Smart Browse For Folder
example of smart usage of BrowseForFolder API function
including
- repositioning and resizing browse window
- adding a listbox, static elements and a button
- catching button click
- filling the listbox with file names
- custom information field
- custom condition for allowing folder selection
- creating new folder
- !!! REFRESHING TREE !!! after folder creation
(thanks to Leonid Kunin for his idea published at
http://codeguru.earthweb.com)
Copyright (C) Konstantin Polyakov, 2001
FIDO: 2:5030/542.251
e-mail: kpolyakov@mail.ru
Web: http://kpolyakov.newmail.ru
------------------------------------------------------------------------}
program SmartBff;
uses Windows, SysUtils, Messages, ActiveX, ShlObj, CommCtrl, Dialogs;
type AWndProc = function (Wnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM):
LRESULT; stdcall;
const
ID_CREATEBTN = 100;
FileMask = '*.dat';
var MainWnd, TreeWnd, LBoxWnd, StatusWnd,
DirLabel, CreateBtn: HWND;
OldWndProc: AWndProc;
PathSelected: string;
//-------------------------------------------------------------------
// FILL LISTBOX
//-------------------------------------------------------------------
procedure FillListBox(LBoxWnd: HWND; Path, Mask: string);
var FindHandle: THandle;
FindData: TWin32FindData;
begin
SendMessage(LBoxWnd, LB_RESETCONTENT, 0, 0);
if Path = '' then Exit;
Path := Path + Mask;
FindHandle := FindFirstFile(PChar(Path), FindData);
while FindHandle <> INVALID_HANDLE_VALUE do begin
if (FILE_ATTRIBUTE_DIRECTORY and FindData.dwFileAttributes) = 0 then
with FindData do begin
if (AnsiStrUpper(cFileName)=cFileName) and (cFileName[1]<>#0) then
AnsiStrLower(cFileName+1);
SendMessage(LBoxWnd, LB_ADDSTRING, 0, Longint(@cFileName[0]));
end;
if not FindNextFile(FindHandle, FindData) then begin
Windows.FindClose(FindHandle);
break;
end;
end;
end;
//-------------------------------------------------------------------
// GET STATUS TEXT
//-------------------------------------------------------------------
function GetStatusText(var Enable: integer; Path: string): string;
begin
Result := '';
if Enable = 0 then begin
Result := 'Можно выбирать каталоги только на жестких дисках';
EnableWindow(CreateBtn, False);
Exit;
end;
EnableWindow(CreateBtn, True);
if SendMessage(LBoxWnd, LB_GETCOUNT, 0, 0) = 0 then begin
Enable := 0;
Result := 'В этой папке нет нужных файлов.';
end;
end;
//-------------------------------------------------------------------
// DO CREATE FOLDER
//-------------------------------------------------------------------
function DoCreateFolder(Wnd: HWND; Folder: string): Boolean;
var i: integer;
FullPath: string;
procedure CreationError(Info: string);
begin
MessageBox(Wnd, PChar(Info), 'Ошибка при создании папки', MB_ICONERROR or MB_OK);
end;
begin
Result := False;
Folder := Trim(Folder);
if (Length(Folder) = 0) or (Folder[1] = '.') then begin
CreationError('Неверное имя папки ' + Folder);
Exit;
end;
for i:=1 to Length(Folder) do
if (Folder[i] in ['<','>',':','/','\','|','*','?','"']) then begin
CreationError('Имя папки не должно содеpжать символов: \ / : * ? " < > |');
Exit;
end;
if Length(PathSelected)=3 then
FullPath := PathSelected + Folder
else FullPath := PathSelected + '\' + Folder;
if not CreateDirectory(PChar(FullPath), nil) then begin
CreationError('Не удалось создать папку ' + FullPath);
Exit;
end;
Result := True;
end;
//-------------------------------------------------------------------
// BROWSE WND PROC
//-------------------------------------------------------------------
function BrowseWndProc(Wnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM):
LRESULT; stdcall;
var wNotifyCode: integer;
wID: integer;
CurItem: HTreeItem;
Item: TTVItem;
Folder, FullPath: string;
begin
if Msg = WM_COMMAND then begin
wNotifyCode := HIWORD(wParam);
wID := LOWORD(wParam);
if (wNotifyCode = BN_CLICKED) and (wID = ID_CREATEBTN) then begin
Result := 0;
Folder := 'New Folder';
if InputQuery('Новая папка', 'Введите имя новой папки', Folder) then begin
if not DoCreateFolder(Wnd, Folder) then Exit;
CurItem := TreeView_GetSelection(TreeWnd);
TreeView_Expand(TreeWnd, CurItem, TVE_COLLAPSE or TVE_COLLAPSERESET);
ZeroMemory(@Item, sizeof(Item));
Item.hItem := CurItem;
Item.mask := TVIF_HANDLE or TVIF_CHILDREN;
Item.cChildren := I_CHILDRENCALLBACK;
TreeView_SetItem(TreeWnd, Item);
TreeView_Expand(TreeWnd, CurItem, TVE_COLLAPSERESET );
FullPath := PathSelected + '\' + Folder;
SendMessage(MainWnd, BFFM_SETSELECTION, 1, integer(PChar(FullPath)) );
Windows.SetFocus(TreeWnd);
end;
Exit;
end;
end;
Result := OldWndProc(Wnd, Msg, wParam, lParam);
end;
//-------------------------------------------------------------------
// MOVE CHILD UP
//-------------------------------------------------------------------
function MoveChildUp(CWnd: HWND; shiftY: integer): longbool; stdcall;
var rct: TRect;
begin
if CWnd <> DirLabel then begin
GetWindowRect(CWnd, rct);
ScreenToClient(MainWnd, rct.TopLeft);
SetWindowPos(CWnd, 0, rct.Left, rct.Top - shiftY, 0, 0,
SWP_NOOWNERZORDER or SWP_NOSIZE );
end;
Result := True;
end;
//-------------------------------------------------------------------
// CREATE BROWSE WINDOW
//-------------------------------------------------------------------
procedure CreateBrowseWindow(Wnd: HWND);
const topMargin = 20;
wLBox = 125;
var rct, rctStatic, rctTree, rctLBox, rctBtn: TRect;
hLBox, lLBox, tLBox: integer;
w, h, wBtn, dh: integer;
FileStatic, BtnWnd: HWND;
FontHandle: THandle;
Style: Integer;
begin
MainWnd := Wnd;
GetWindowRect(Wnd, rct);
w := rct.Right - rct.Left + 135;
h := rct.Bottom - rct.Top;
// find treeview
TreeWnd := FindWindowEx(Wnd, 0, PChar('SysTreeView32'), nil);
GetWindowRect(TreeWnd, rctTree);
ScreenToClient(Wnd, rctTree.TopLeft);
ScreenToClient(Wnd, rctTree.BottomRight);
// HideSelection := False
Style := GetWindowLong(TreeWnd, GWL_STYLE);
SetWindowLong(TreeWnd, GWL_STYLE, Style or TVS_SHOWSELALWAYS );
// store treeview font handle
FontHandle := SendMessage(TreeWnd, WM_GETFONT, 0, 0);
// find static text element
DirLabel := FindWindowEx(Wnd, 0, PChar('Static'), nil);
GetWindowRect(DirLabel, rctStatic);
ScreenToClient(Wnd, rctStatic.TopLeft);
dh := rctTree.Top - rctStatic.Top - topMargin;
// find button
BtnWnd := FindWindowEx(Wnd, 0, PChar('Button'), nil);
GetWindowRect(BtnWnd, rctBtn);
ScreenToClient(Wnd, rctBtn.TopLeft);
ScreenToClient(Wnd, rctBtn.BottomRight);
// move all child windows up by 'dh'
EnumChildWindows(Wnd, @MoveChildUp, dh);
// resize static text
SetWindowPos(DirLabel, 0, 0, 0,
rctTree.Right - rctTree.Left,
rctTree.Top - dh - rctStatic.Top,
SWP_NOOWNERZORDER or SWP_NOMOVE );
// create listbox
hLBox := rctTree.Bottom - rctTree.Top - 60;
lLBox := rctTree.Right + 10;
tLBox := rctStatic.Top + topMargin - 1;
LBoxWnd := CreateWindowEx(WS_EX_CLIENTEDGE, 'listbox', nil,
WS_VISIBLE or WS_CHILD or
LBS_STANDARD or LBS_NOINTEGRALHEIGHT or LBS_NOSEL,
lLBox, tLBox, wLBox, hLBox,
Wnd, 0, hInstance, nil);
SendMessage(LBoxWnd, WM_SETFONT, FontHandle, 1);
// create additional static element
FileStatic := CreateWindow('static', 'Файлы с данными',
WS_VISIBLE or SS_SIMPLE or WS_CHILD,
rctTree.Right+10, rctStatic.Top,
wLBox,
rctTree.Top - dh - rctStatic.Top,
Wnd,
0, hInstance, nil);
SendMessage(FileStatic, WM_SETFONT, FontHandle, 1);
// new comment static
StatusWnd := CreateWindowEx(WS_EX_STATICEDGE, 'static', '',
WS_VISIBLE Or SS_LEFT Or WS_CHILD,
lLBox, tLBox + hLBox + 10,
wLBox, 50,
Wnd,
0, hInstance, nil);
SendMessage(StatusWnd, WM_SETFONT, FontHandle, 1);
// new button 'Create'
GetWindowRect(LBoxWnd, rctLBox);
ScreenToClient(Wnd, rctLBox.BottomRight);
wBtn := rctBtn.Right - rctBtn.Left;
CreateBtn := CreateWindow('button', 'Создать...',
WS_VISIBLE Or WS_CHILD,
rctLBox.Right - wBtn, rctBtn.Top - dh,
wBtn,
rctBtn.Bottom - rctBtn.Top,
Wnd,
ID_CREATEBTN, hInstance, nil);
SendMessage(CreateBtn, WM_SETFONT, FontHandle, 1);
// replace window procedure
OldWndProc := AWndProc(GetWindowLong(Wnd, GWL_WNDPROC));
SetWindowLong(Wnd, GWL_WNDPROC, Longint(@BrowseWndProc));
// place window at the screen center
SetWindowPos(Wnd, HWND_TOP, (800 - w) div 2,
(600 - h) div 2 - 20, w, h - dh, 0 );
// change window title
SetWindowText(Wnd, PChar('Выбор каталога с данными'));
end;
//-------------------------------------------------------------------
// BROWSE CALLBACK PROC
//-------------------------------------------------------------------
function BrowseCallbackProc( Wnd : THandle; uMsg : UINT;
lParam : Integer; lpData : Pointer ) : Integer; stdcall;
var Path : array[0..MAX_PATH-1] of Char;
RootDir, StatusText: string;
Enable: Integer;
begin
case uMsg of
BFFM_INITIALIZED: begin
CreateBrowseWindow(Wnd);
if Assigned( lpData ) then
SendMessage( Wnd, BFFM_SETSELECTION, 1, Integer(lpData) );
end;
BFFM_SELCHANGED: begin
Enable := 0;
StatusText := '';
if Assigned( lpData ) then begin
SHGetPathFromIDList( PItemIdList(lparam), @Path[0] );
SetWindowText(DirLabel, Path);
PathSelected := Path;
RootDir := Copy( Path, 1, Pos('\', Path ) );
if GetDriveType( PChar( RootDir ) ) = DRIVE_FIXED then
Enable := 1;
FillListBox(LBoxWnd, Path, '\' + FileMask);
StatusText := GetStatusText(Enable, Path);
SetWindowText(StatusWnd, PChar(StatusText));
end;
SendMessage( Wnd, BFFM_ENABLEOK, 0, Enable );
end;
end;
Result := 0;
end;
//-------------------------------------------------------------------
// CHOOSE FOLDER
//-------------------------------------------------------------------
function ChooseFolder(Title, StartPath: string; Flags: UINT): string;
var bi: TBrowseInfo;
buf: PChar;
DrivesPIDL: PItemIDList;
ItemIDList: PItemIDList;
ShellMalloc: IMalloc;
begin
Result:='';
// if not DirectoryExists(StartPath) then
// StartPath := ExtractFileDir(ParamStr(0));
If (ShGetMalloc(ShellMalloc) <> S_OK) or (ShellMalloc = nil) then Exit;
SHGetSpecialFolderLocation( 0, CSIDL_DRIVES, DrivesPIDL );
buf:= ShellMalloc.Alloc(MAX_PATH);
FillChar(bi, sizeof(bi), 0);
try
bi.hwndOwner := 0; //Application.Handle;
bi.pidlRoot := DrivesPIDL;
bi.pszDisplayName := @buf[1];
bi.lpszTitle := PChar(title);
bi.ulFlags := BIF_RETURNONLYFSDIRS or Flags;
bi.lpfn := @BrowseCallbackProc;
bi.iImage := 0;
bi.lParam := Integer( StartPath );
ItemIDList := ShBrowseForFolder(bi);
If ItemIDList <> nil then begin
ShGetPathFromIDList(ItemIDList, buf);
ShellMalloc.Free(ItemIDList);
Result := buf;
end;
finally
ShellMalloc.Free(buf);
end;
end;
//-------------------------------------------------------------------
// MAIN PROGRAM
//-------------------------------------------------------------------
begin
ChooseFolder('Выбор каталога с файлами ' + FileMask, 'G:\DOC', 0 );
end.А как это сделать на VBA?
- Миша
- Восстановленный участник
Re: VBA. КАК ВЫБРАТЬ ДИРЕКТОРИЮ
Подскажите хотя-бы где в приведённом выше коде строки относящиеся к изменению размеров окна выбора директории и к начальному указанию заранее выбранной директории при перврначальном отображении окна на экране!
Сообщения 5
Тему читают: 1 гость
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Форумы CADUser → Программирование → VBA → VBA. КАК ВЫБРАТЬ ДИРЕКТОРИЮ
Форум работает на PunBB, при поддержке Informer Technologies, Inc
