dwg.ru forum rss xml
| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > VBA. BrowseForFolder. Конвертация API-функции под 64 битные системы

VBA. BrowseForFolder. Конвертация API-функции под 64 битные системы

Версия для печати
 
Ответ
Опции темы Поиск в этой теме
Непрочитано 26.12.2017, 16:50 #1
VBA. BrowseForFolder. Конвертация API-функции под 64 битные системы
AlexV
 
Инженер
 
С-Пб
Регистрация: 02.10.2008
Сообщений: 3,595

AlexV вне форума Вставить имя

На заре туманной юности, во времена автокада 2004 был мною где-то скопипащен код, позволяющий в макросах vba вызывать системные окошки выбора файлов через api (возможно, функционал его шире, я использовал именно для этого). А не поделится ли кто-нибудь аналогичным кодом для 64 битных систем? В инете пошукал темы, но - ума и знаний не хватает, что бы самому разобраться..

Код:
[Выделить все]
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

'
' NOTE: Many of these flags only work with certain versions of Shell32.dll:
'
Public Enum WhatBrowse
    'Only return file system directories. If the user selects
    'folders that are not part of the file system, the OK
    'button is grayed:
    BIF_RETURNONLYFSDIRS = &H1
    'The browse dialog will display files as well as folders:
    BIF_BROWSEINCLUDEFILES = &H1 Or &H4000
    'Only return computers. If the user selects anything
    'other than a computer, the OK button is grayed:
    BIF_BROWSEFORCOMPUTER = &H1000
    'Only return printers. If the user selects anything
    'other than a printer, the OK button is grayed:
    BIF_BROWSEFORPRINTER = &H2000
    'Do not include network folders below the domain
    'level in the tree view control:
    BIF_DONTGOBELOWDOMAIN = &H2
    'Include a status area in the dialog box. The callback
    'function can set the status text by sending messages
    'to the dialog box:
    BIF_STATUSTEXT = &H4
    'Use the new user-interface providing the user with a larger
    'resizable dialog box which includes drag and drop, reordering,
    'context menus, new folders, delete, and other context menu
    'commands:
    BIF_NEWDIALOGSTYLE = &H40
    'Include an edit control in the dialog box:
    BIF_EDITBOX = &H10
    'Equivalent to BIF_EDITBOX | BIF_NEWDIALOGSTYLE:
    BIF_USENEWUI = (BIF_NEWDIALOGSTYLE Or BIF_EDITBOX)
    'Only return file system ancestors. If the user
    'selects anything other than a file system ancestor,
    'the OK button is grayed:
    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
    
    ' ***
    ' ***
    ' ***   hWnd_Owner      - 
    ' ***   sPrompt         - ,
    ' ***   WhatBr          -
    ' ***   DialogTitle     - 
    ' ***   initDir         -
    ' ***   fileMasks       - 
    ' ***                     
    ' ***                     
    ' ***   ChangeSize      -
    ' ***   RatioX          - 
    ' ***   RatioY          - 
    ' ***   CenterOnScreen  - 
    ' ***   TopMost        
    ' ***
    
    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  ' << Sugested by MS to prevent an error from propagating back into the calling process.
       
    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)
'                        Debug.Print sPath + g_FileMasks(i)
                        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
    ' This function allows you to assign a function pointer to a vaiable.
    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
    
'    Debug.Print "g_newLeft:", g_newLeft, "g_newTop:", g_newTop
    
    ' Îïðåäåëÿåì äåñêðèïòîðû ïîòîêà è ïðîöåññà, ïîðîäèâøèõ íàø äèàëîã:
    thread_id = GetWindowThreadProcessId(hWnd, pid)
'    Debug.Print "Õýíäë ïîòîêà = " + CStr(thread_id)
    
    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
'        Debug.Print "Õýíäë êíîïêè OK = " + CStr(okButtonHwnd)
        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
'            Debug.Print "Õýíäë êíîïêè Îòìåíà = " + CStr(cancelButtonHwnd)
            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
'        Debug.Print "Õýíäë äåðåâà = " + CStr(treeHwnd)
        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
'        Debug.Print "Õýíäë ëåéáëà ñ ïîäñêàçêîé = " + CStr(promptHwnd)
        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
'            Debug.Print " " + CStr(folderHwnd)
            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
__________________
...Не пытайся гнуть ты ложку,
Не вяжи её узлом.
Ложка - ложка понарошку,
А по правде, - это лом!
Просмотров: 1131
 
Непрочитано 26.12.2017, 17:39
1 | #2
Александр Ривилис

программист, рыцарь ObjectARX
 
Регистрация: 09.05.2005
Киев
Сообщений: 2,175
Отправить сообщение для Александр Ривилис с помощью ICQ Отправить сообщение для Александр Ривилис с помощью Skype™


Попробуй: https://forums.autodesk.com/t5/inven...4367031#M45685
Александр Ривилис вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Автор темы   Непрочитано 26.12.2017, 18:11
#3
AlexV

Инженер
 
Регистрация: 02.10.2008
С-Пб
Сообщений: 3,595


Цитата:
Сообщение от Александр Ривилис Посмотреть сообщение
Спасибо! Отлично, все работает!
__________________
...Не пытайся гнуть ты ложку,
Не вяжи её узлом.
Ложка - ложка понарошку,
А по правде, - это лом!
AlexV вне форума вставить имя Обратить внимание модератора на это сообщение  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > VBA. BrowseForFolder. Конвертация API-функции под 64 битные системы

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск

Быстрый переход

Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
СП 335.1325800.2017 «Крупнопанельные конструктивные системы. Правила проектирования» (Обсуждение) Armin Прочее. Архитектура и строительство 35 05.05.2018 14:46
Как увеличить коэффициент устойчивости системы? Снежный человек SCAD 21 19.04.2017 16:22
Как правильно определить коэффициент запаса устойчивости системы Igor1985 SCAD 1 08.12.2016 14:07
Нужно ли учитывать крестовые связи при проверке общей устойчивости системы в SCAD? Sokrat SCAD 27 16.12.2015 11:59
Функции формы элемента. Обясните пожалуйста Nursul85 Расчетные программы 4 23.11.2015 09:12

|| Главная || Каталог САПР || Тендеры || Публикации || Объявления || Биржа труда || Download || Галерея ||
|| Библиотека || Кунсткамера || Каталог предприятий || Контакты || Файлообменник || Блоги ||