Выбор директории

(ACET-UI-PICKDIR)

Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Public Declare Function MoveWindow Lib "user32.dll" ( _
     ByVal hWnd As Long, _
     ByVal X As Long, _
     ByVal y As Long, _
     ByVal nWidth As Long, _
     ByVal nHeight As Long, _
     ByVal bRepaint As Long) As Long
Public Declare Function GetWindowRect Lib "user32.dll" ( _
     ByVal hWnd As Long, _
     lpRect As RECT) As Long
Public Declare Function WaitForInputIdle Lib "user32" ( _
    ByVal hProcess As Long, _
    ByVal dwMilliseconds As Long) As Long
Public Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" ( _
     ByVal hWnd1 As Long, _
     ByVal hWnd2 As Long, _
     ByVal lpsz1 As String, _
     ByVal lpsz2 As String) As Long
Public Declare Function EnumThreadWindows Lib "user32" _
    (ByVal dwThreadId As Long, _
    ByVal lpfn As Long, _
    ByVal lParam As Long) As Long
Public Declare Function GetWindowThreadProcessId Lib "user32.dll" ( _
     ByVal hWnd As Long, _
     lpdwProcessId As Long) As Long
Public Declare Function SetWindowPos Lib "user32.dll" ( _
     ByVal hWnd As Long, _
     ByVal hWndInsertAfter As Long, _
     ByVal X As Long, _
     ByVal y As Long, _
     ByVal cx As Long, _
     ByVal cy As Long, _
     ByVal wFlags As Long) As Long
Public Declare Function SetWindowText Lib "user32.dll" Alias "SetWindowTextA" ( _
     ByVal hWnd As Long, _
     ByVal lpString As String) As Long
Public Const SWP_SHOWWINDOW = &H40
Public Const HWND_TOPMOST = -1
Public g_CurrentDirectory As String
Public g_FileMasks() As String
Public g_ChangeSize As Boolean
Public g_DialogTitle As String
Public g_RatioX As Double, g_RatioY As Double
Public g_CenterOnScreen As Boolean
Public g_TopMost As Boolean
Public g_newLeft As Long, g_newTop As Long
Public g_deltaH As Long, g_deltaW As Long
Public Const WM_USER As Long = &H400
Public Const BFFM_INITIALIZED = 1
Public Const BFFM_SELCHANGED = 2
Public Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Public Const BFFM_ENABLEOK = (WM_USER + 101)
Public Const BFFM_SETSELECTION = (WM_USER + 102)
Public Type BrowseInfo
    hWndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type
Public Enum WhatBrowse
    BIF_RETURNONLYFSDIRS = &H1
    BIF_BROWSEINCLUDEFILES = &H1 Or &H4000
    BIF_BROWSEFORCOMPUTER = &H1000
    BIF_BROWSEFORPRINTER = &H2000
    BIF_DONTGOBELOWDOMAIN = &H2
    BIF_STATUSTEXT = &H4
    BIF_NEWDIALOGSTYLE = &H40
    BIF_EDITBOX = &H10
    BIF_USENEWUI = (BIF_NEWDIALOGSTYLE Or BIF_EDITBOX)
    BIF_RETURNFSANCESTORS = &H8
End Enum
Public Const MAX_PATH = 260&
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
  (ByVal hWnd As Long, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
   lParam As Any) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _
    (ByVal lpString1 As String, _
    ByVal lpString2 As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" _
    (ByVal pidList As Long, _
    ByVal lpBuffer As String) As Long
Public Function fBrowseForFolder(ByVal hWnd_Owner As Long, _
                                 ByVal sPrompt As String, _
                                 ByVal WhatBr As Long, _
                                 ByVal DialogTitle As String, _
                                 Optional ByVal initDir As String = "", _
                                 Optional ByRef fileMasks As String = "", _
                                 Optional ByVal ChangeSize As Boolean = False, _
                                 Optional ByVal RatioX As Double = 1, _
                                 Optional ByVal RatioY As Double = 1, _
                                 Optional ByVal CenterOnScreen As Boolean = False, _
                                 Optional ByVal PromptColor As Long = 0&, _
                                 Optional ByVal PathColor As Long = 0&, _
                                 Optional ByVal TopMost As Boolean) As String
    Dim iNull As Integer
    Dim lpIDList As Long
    Dim lResult As Long
    Dim sPath As String
    Dim udtBI As BrowseInfo
    g_DialogTitle = DialogTitle
    g_ChangeSize = ChangeSize
    g_RatioX = RatioX
    g_RatioY = RatioY
    g_CenterOnScreen = CenterOnScreen
    g_TopMost = TopMost
    If initDir = "" Then
        g_CurrentDirectory = ""
    Else
        g_CurrentDirectory = initDir & vbNullChar
    End If
    If fileMasks = "" Then
        ReDim g_FileMasks(0 To 0)
        g_FileMasks(0) = ""
    Else
        g_FileMasks = Split(fileMasks, "|")
    End If
    With udtBI
        .hWndOwner = hWnd_Owner
        .lpszTitle = lstrcat(sPrompt, "")
        .ulFlags = WhatBr
        .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)  'get address of function.
    End With
    lpIDList = SHBrowseForFolder(udtBI)
    If lpIDList Then
        sPath = String$(MAX_PATH, 0)
        lResult = SHGetPathFromIDList(lpIDList, sPath)
        Call CoTaskMemFree(lpIDList)
        iNull = InStr(sPath, vbNullChar)
        If iNull Then sPath = Left$(sPath, iNull - 1)
    End If
    fBrowseForFolder = sPath
End Function
Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
    Dim lpIDList As Long
    Dim ret As Long
    Dim sBuffer As String
    Dim i As Integer, flag As Boolean, sPath As String
    On Error Resume Next
    Select Case uMsg
        Case BFFM_INITIALIZED
            If g_CurrentDirectory <> "" Then
                Call SendMessage(hWnd, BFFM_SETSELECTION, 1, ByVal g_CurrentDirectory)
            End If
            SetWindowText hWnd, g_DialogTitle
            If g_ChangeSize Then
                Call ResizeDialog(hWnd)
            Else
                If g_CenterOnScreen Then Call CenterDialog(hWnd)
            End If
        Case BFFM_SELCHANGED
            sBuffer = Space$(MAX_PATH)
            ret = SHGetPathFromIDList(lp, sBuffer)
            If ret = 1 Then
                Call SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, ByVal sBuffer)
                If g_FileMasks(0) <> "" Then
                    sPath = Left$(sBuffer, InStr(1, sBuffer, vbNullChar) - 1)
                    If Right$(sPath, 1) <> "\" Then sPath = sPath + "\"
                    flag = False
                    For i = 0 To UBound(g_FileMasks)
                        If Dir(sPath + g_FileMasks(i)) <> "" Then flag = True
                    Next i
                    If flag Then
                        Call SendMessage(hWnd, BFFM_ENABLEOK, 0, ByVal 1&)
                    Else
                        Call SendMessage(hWnd, BFFM_ENABLEOK, 0, ByVal 0&)
                    End If
                End If
            End If
        Case Else
    End Select
    BrowseCallbackProc = 0
End Function
Public Function GetAddressofFunction(add As Long) As Long
    GetAddressofFunction = add
End Function
Private Sub ResizeDialog(ByVal hWnd As Long)
    Dim pid As Long, thread_id As Long
    Dim screenWidth As Long, screenHeight As Long
    Dim winWidth As Long, winHeight As Long
    Dim R As RECT
    screenWidth = Screen.Width / Screen.TwipsPerPixelX
    screenHeight = Screen.Height / Screen.TwipsPerPixelY
    GetWindowRect hWnd, R
    winWidth = (R.Right - R.Left) * g_RatioX
    winHeight = (R.Bottom - R.Top) * g_RatioY
    g_deltaH = winHeight - (R.Bottom - R.Top)
    g_deltaW = winWidth - (R.Right - R.Left)
    If g_CenterOnScreen Then
        g_newLeft = (screenWidth - winWidth) / 2
        g_newTop = (screenHeight - winHeight) / 2
    Else
        g_newLeft = R.Left
        g_newTop = R.Top
    End If
    If g_TopMost Then
        SetWindowPos hWnd, HWND_TOPMOST, g_newLeft, g_newTop, winWidth, winHeight, SWP_SHOWWINDOW
    Else
        SetWindowPos hWnd, 0, g_newLeft, g_newTop, winWidth, winHeight, SWP_SHOWWINDOW
    End If
    thread_id = GetWindowThreadProcessId(hWnd, pid)
    Call WaitForInputIdle(pid, 1000&)
    EnumThreadWindows thread_id, AddressOf EnumThreadWndProc, 0&
End Sub
Public Function EnumThreadWndProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
    Dim treeHwnd As Long, okButtonHwnd As Long, cancelButtonHwnd As Long, promptHwnd As Long, folderHwnd As Long
    Dim R As RECT
    Static allControlsAdjusted As Integer
    okButtonHwnd = FindWindowEx(hWnd, ByVal 0&, "Button", vbNullString)
    If okButtonHwnd <> 0 Then
        GetWindowRect okButtonHwnd, R
        MoveWindow okButtonHwnd, (R.Left - g_newLeft - 3) + g_deltaW, (R.Top - g_newTop - 22) + g_deltaH, R.Right - R.Left, R.Bottom - R.Top, 1
        allControlsAdjusted = allControlsAdjusted + 10000
        cancelButtonHwnd = FindWindowEx(hWnd, okButtonHwnd, "Button", vbNullString)
        If cancelButtonHwnd <> 0 Then
            GetWindowRect cancelButtonHwnd, R
            MoveWindow cancelButtonHwnd, (R.Left - g_newLeft - 3) + g_deltaW, (R.Top - g_newTop - 22) + g_deltaH, R.Right - R.Left, R.Bottom - R.Top, 1
            allControlsAdjusted = allControlsAdjusted + 1000
        End If
    End If
    treeHwnd = FindWindowEx(hWnd, ByVal 0&, "SysTreeView32", vbNullString)
    If treeHwnd <> 0 Then
        GetWindowRect treeHwnd, R
        MoveWindow treeHwnd, R.Left - g_newLeft - 3, R.Top - g_newTop - 22, (R.Right - R.Left) + g_deltaW, (R.Bottom - R.Top) + g_deltaH, 1
        allControlsAdjusted = allControlsAdjusted + 100
    End If
    promptHwnd = FindWindowEx(hWnd, ByVal 0&, "Static", vbNullString)
    If promptHwnd <> 0 Then
        GetWindowRect promptHwnd, R
        MoveWindow promptHwnd, R.Left - g_newLeft - 3, R.Top - g_newTop - 22, (R.Right - R.Left) + g_deltaW, R.Bottom - R.Top, 1
        allControlsAdjusted = allControlsAdjusted + 10
        folderHwnd = FindWindowEx(hWnd, promptHwnd, "Static", vbNullString)
        If folderHwnd <> 0 Then
            GetWindowRect folderHwnd, R
            MoveWindow folderHwnd, R.Left - g_newLeft - 3, R.Top - g_newTop - 22, (R.Right - R.Left) + g_deltaW, R.Bottom - R.Top, 1
            allControlsAdjusted = allControlsAdjusted + 1
        End If
    End If
    EnumThreadWndProc = Not (allControlsAdjusted = 11111)
End Function
Private Sub CenterDialog(ByVal hWnd As Long)
    Dim screenWidth As Long, screenHeight As Long
    Dim winWidth As Long, winHeight As Long
    Dim R As RECT
    screenWidth = Screen.Width / Screen.TwipsPerPixelX
    screenHeight = Screen.Height / Screen.TwipsPerPixelY
    GetWindowRect hWnd, R
    winWidth = (R.Right - R.Left)
    winHeight = (R.Bottom - R.Top)
    g_newLeft = (screenWidth - winWidth) / 2
    g_newTop = (screenHeight - winHeight) / 2
    SetWindowPos hWnd, 0, g_newLeft, g_newTop, winWidth, winHeight, SWP_SHOWWINDOW
End Sub

    Dim st As String
    st = fBrowseForFolder(hWnd_Owner:=0&, _
                          sPrompt:="Выберите папку, содержащую файлы *.DWG и *.TIF:", _
                          WhatBr:=BIF_RETURNONLYFSDIRS Or BIF_STATUSTEXT, _
                          DialogTitle:="Супер диалог выбора папок", _
                          initDir:="C:\", _
                          fileMasks:="*.DWG|*.TIF", _
                          ChangeSize:=True, _
                          RatioX:=1.4, _
                          RatioY:=1.7, _
                          CenterOnScreen:=True, _
                          TopMost:=True)
    If Len(st) > 0 Then MsgBox "Вы выбрали папку:" + vbCr + st, vbInformation, "Информация"

 lngHandle = CreateWindowExA(0, "button", "Новая папка", &H40000000, 10, .Top - R.Top - (.Bottom - .Top) + 1, 95, .Bottom - .Top, hwnd, 0, App.hInstance, ByVal 0)