Окно выбора директории (папки) - VB
Формулировка задачи:
Всем привет!
Давно ищу в интернете нормальное диалоговое окно выбора директории (по типа того что предоставляет CommonDialog для выбора файлов). Кстати на VBA такая вещь присутствует!
Вот пример на VBA :
Решение задачи: «Окно выбора директории (папки)»
textual
Листинг программы
Option Explicit Private Type OPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As String nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String Flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As String pvReserved As Long dwReserved As Long FlagsEx As Long End Type Public Enum CdlgExt_Flags OFNAllowMultiselect = &H200 OFNCreatePrompt = &H2000 OFNexplorer = &H80000 OFNEnableHook = &H20 OFNExtensionDifferent = &H400 OFNFileMustExist = &H1000 OFNHelpButton = &H10 OFNHideReadOnly = &H4 OFNLongNames = &H200000 OFNNoChangeDir = &H8 OFNNoDereferenceLinks = &H100000 OFNNoLongNames = &H40000 OFNNoReadOnlyReturn = &H8000 OFNNoValidate = &H100 OFNOverwritePrompt = &H2 OFNPathMustExist = &H800 OFNReadOnly = &H1 OFNShareAware = &H4000 End Enum Private Type NMHDR hwndFrom As Long idfrom As Long code As Long End Type Private Type LVITEM mask As Long iItem As Long iSubItem As Long state As Long stateMask As Long pszText As String cchTextMax As Long iImage As Long lParam As Long iIndent As Long End Type Private Const GWL_WNDPROC = (-4) Private Const WM_INITDIALOG = &H110 Private Const WM_DESTROY = &H2 Private Const WM_NOTIFY = &H4E Private Const WM_USER = &H400 Private Const WM_COMMAND = &H111 Private Const CDN_FIRST = -601& Private Const CDN_INITDONE = (CDN_FIRST - 0&) Private Const CDN_FILEOK = (CDN_FIRST - 5&) Private Const CDM_FIRST = (WM_USER + 100) Private Const CDM_HIDECONTROL = (CDM_FIRST + &H5) Private Const CDM_SETCONTROLTEXT = (CDM_FIRST + &H4) Private Const CDM_GETFOLDERPATH = (CDM_FIRST + &H2) Private Const BN_CLICKED As Long = &H0 Private Const MAX_PATH = 260 Private Const IDOK = 1 Private Const IDFILETYPECOMBO = &H470 Private Const IDFILETYPESTATIC = &H441 ' Files of Type Private Const IDFILENAMESTATIC = &H442 ' File Name Private Const IDFILELIST = &H460 ' Listbox Private Const LVM_FIRST = &H1000& Private Const LVM_GETSELECTEDCOUNT = LVM_FIRST + 50 Private Const LVM_GETNEXTITEM = (LVM_FIRST + 12) Private Const LVM_GETITEMTEXT = LVM_FIRST + 45 Private Const LVIS_SELECTED = &H2& Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenFilename As OPENFILENAME) As Long Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal Count As Long) Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long Dim OFN As OPENFILENAME Dim OldWndProc As Long Dim hwndDlg As Long Dim mFolders As Collection Dim mPath As String Public Property Get Folders() As Collection Set Folders = mFolders End Property Public Property Get Path() As String Path = mPath End Property Public Function PickFolder() As String If mFolders Is Nothing Then Set mFolders = New Collection Do While mFolders.Count: mFolders.Remove (1): Loop With OFN .lStructSize = Len(OFN) .hInstance = App.hInstance .lpfnHook = lHookAddress(AddressOf DialogHookFunction) .Flags = OFNexplorer Or OFNNoChangeDir Or OFNEnableHook Or OFNHideReadOnly Or OFNAllowMultiselect .lpstrFile = String$(MAX_PATH, 0) .nMaxFile = MAX_PATH .lpstrFileTitle = String$(MAX_PATH, 0) .nMaxFileTitle = MAX_PATH .lpstrFilter = "Folders" & Chr$(0) & "*.ЛЮБОЕ НЕСУЩЕСТВУЮЩЕЕ РАСШИРЕНИЕ" & String$(2, Chr$(0)) .lpstrTitle = "Pick folders" .nFilterIndex = 0 End With GetOpenFileName OFN End Function Private Function lHookAddress(lPtr As Long) As Long lHookAddress = lPtr End Function Private Function DialogHookFunction(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Select Case wMsg Case WM_INITDIALOG hwndDlg = GetParent(hDlg) OldWndProc = SetWindowLong(hwndDlg, GWL_WNDPROC, AddressOf DlgWndProc) Case WM_NOTIFY Dim tNMH As NMHDR CopyMemory tNMH, ByVal lParam, Len(tNMH) Select Case tNMH.code Case CDN_INITDONE SendMessage hwndDlg, CDM_SETCONTROLTEXT, IDOK, ByVal "Pick folder" SendMessage hwndDlg, CDM_SETCONTROLTEXT, IDFILENAMESTATIC, ByVal "Folder name" SendMessage hwndDlg, CDM_HIDECONTROL, IDFILETYPECOMBO, ByVal 0& SendMessage hwndDlg, CDM_HIDECONTROL, IDFILETYPESTATIC, ByVal 0& End Select Case WM_DESTROY Case Else End Select End Function Private Function DlgWndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Select Case Msg Case WM_COMMAND If HiWord(wParam) = BN_CLICKED Then Dim hwndPick As Long hwndPick = GetDlgItem(hwndDlg, IDOK) If lParam = hwndPick Then Dim hwndLVParent As Long, hwndLV As Long Dim Pos As Long, Itm As LVITEM, txtLen As Long hwndLVParent = FindWindowEx(hwndDlg, ByVal 0&, "SHELLDLL_DefView", vbNullString) hwndLV = FindWindowEx(hwndLVParent, ByVal 0&, "SysListView32", vbNullString) Pos = SendMessage(hwndLV, LVM_GETNEXTITEM, -1, ByVal LVIS_SELECTED) If Pos >= 0 Then Itm.cchTextMax = MAX_PATH Itm.pszText = String(MAX_PATH, 0) txtLen = SendMessage(hwndLV, LVM_GETITEMTEXT, Pos, Itm) mFolders.Add Left(Itm.pszText, txtLen) Do Until Pos = -1 Pos = SendMessage(hwndLV, LVM_GETNEXTITEM, Pos, ByVal LVIS_SELECTED) txtLen = SendMessage(hwndLV, LVM_GETITEMTEXT, Pos, Itm) If Pos >= 0 Then mFolders.Add Left(Itm.pszText, txtLen) Loop mPath = String(MAX_PATH, 0) txtLen = SendMessage(hwndDlg, CDM_GETFOLDERPATH, MAX_PATH, ByVal mPath) mPath = Left(mPath, txtLen - 1) DestroyWindow hwndDlg End If Else DlgWndProc = CallWindowProc(OldWndProc, hwnd, Msg, wParam, lParam) End If End If Case Else DlgWndProc = CallWindowProc(OldWndProc, hwnd, Msg, wParam, lParam) End Select End Function Private Function LoWord(ByVal LongIn As Long) As Integer Call CopyMemory(LoWord, LongIn, 2) End Function Private Function HiWord(ByVal LongIn As Long) As Integer Call CopyMemory(HiWord, ByVal (VarPtr(LongIn) + 2), 2) End Function
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д