Диалог открытия файла/папки для Windows 10

Автор Тема: Диалог открытия файла/папки для Windows 10  (Прочитано 5576 раз)

0 Пользователей и 1 Гость просматривают эту тему.

Тема содержит сообщение с Решением. Нажмите здесь чтобы посмотреть его.

Оффлайн AnatolyАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 62
  • Карма: 3
  • Skype: ant_nkh
Есть ли решение для Windows 10 + Autocad 2019-2020?
То, что работало для Windows 7 теперь не работает.

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
То, что работало для Windows 7 теперь не работает.
Что работало в Windows 7 и не работает в Windows 10? Код покажи.
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн AnatolyАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 62
  • Карма: 3
  • Skype: ant_nkh
Вот это работало (ваш пост №2)
https://forum.dwg.ru/showthread.php?t=144529

Теперь в функции FolderBrowse после выбора в диалоговом окне  папки автокад рушится на
Код - Visual Basic [Выбрать]
  1. If SHGetPathFromIDList(pItem, sFullPath) Then


« Последнее редактирование: 11-09-2020, 12:44:48 от Александр Ривилис »

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн AnatolyАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 62
  • Карма: 3
  • Skype: ant_nkh
Надо еще заменить
Код - Visual Basic [Выбрать]
  1. Public Function FolderBrowse(ByVal sDialogTitle As String, ByVal sInitFolder As String) As String
  2. ....
  3. Dim pItem As Long
  4.  

на LongPtr

Спасибо, заработало.

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Anatoly,
Выложи тогда полный код, чтобы если кому-то понадобится могли им воспользоваться.
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн AnatolyАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 62
  • Карма: 3
  • Skype: ant_nkh
Проверил работу только SHBrowseForFolder для Win10
Использование
Код - Visual Basic [Выбрать]
  1. fold = FolderBrowse("", fldnam) ' полный путь к выбранной папке
  2. ' fldnam путь, с которого начинаем диалог, если пусто, то с верхнего уровня
--------------------------------------------------------------
Код - Visual Basic [Выбрать]
  1. Option Explicit
  2. '----------------------------------------------------------------------
  3. ' 64 bit VBA 7 version of File and Folder Browswers
  4. ' FileBrowseOpen() ' FileBrowseSave() ' FolderBrowse()
  5. '----------------------------------------------------------------------
  6.  
  7. Public Declare PtrSafe Function SendMessageA Lib "user32" _
  8. (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
  9.  
  10. Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
  11. Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr
  12.  
  13. Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
  14. Alias "SHGetPathFromIDListA" (ByVal pidList As LongPtr, ByVal lpBuffer As String) As Boolean
  15.  
  16. Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As LongPtr)
  17.  
  18. Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
  19. "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
  20.  
  21. Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
  22. "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
  23.  
  24. Private Const BIF_RETURNONLYFSDIRS As Long = 1
  25. Private Const CSIDL_DRIVES As Long = &H11
  26. Private Const WM_USER As Long = &H400
  27. Private Const MAX_PATH As Long = 260
  28.  
  29. '// message from browser
  30. Private Const BFFM_INITIALIZED As Long = 1
  31. Private Const BFFM_SELCHANGED As Long = 2
  32. Private Const BFFM_VALIDATEFAILEDA As Long = 3 '// lParam:szPath ret:1(cont),0(EndDialog)
  33. Private Const BFFM_VALIDATEFAILEDW As Long = 4 '// lParam:wzPath ret:1(cont),0(EndDialog)
  34. Private Const BFFM_IUNKNOWN As Long = 5 '// provides IUnknown to client. lParam: IUnknown*
  35.  
  36. '// messages to browser
  37. Private Const BFFM_SETSTATUSTEXTA As Long = WM_USER + 100
  38. Private Const BFFM_ENABLEOK As Long = WM_USER + 101
  39. Private Const BFFM_SETSELECTIONA As Long = WM_USER + 102
  40. Private Const BFFM_SETSELECTIONW As Long = WM_USER + 103
  41. Private Const BFFM_SETSTATUSTEXTW As Long = WM_USER + 104
  42. Private Const BFFM_SETOKTEXT As Long = WM_USER + 105 '// Unicode only
  43. Private Const BFFM_SETEXPANDED As Long = WM_USER + 106 '// Unicode only
  44.  
  45. Public Const OFN_ALLOWMULTISELECT As Long = &H200
  46. Public Const OFN_CREATEPROMPT As Long = &H2000
  47. Public Const OFN_ENABLEHOOK As Long = &H20
  48. Public Const OFN_ENABLETEMPLATE As Long = &H40
  49. Public Const OFN_ENABLETEMPLATEHANDLE As Long = &H80
  50. Public Const OFN_EXPLORER As Long = &H80000
  51. Public Const OFN_EXTENSIONDIFFERENT As Long = &H400
  52. Public Const OFN_FILEMUSTEXIST As Long = &H1000
  53. Public Const OFN_HIDEREADONLY As Long = &H4
  54. Public Const OFN_LONGNAMES As Long = &H200000
  55. Public Const OFN_NOCHANGEDIR As Long = &H8
  56. Public Const OFN_NODEREFERENCELINKS As Long = &H100000
  57. Public Const OFN_NOLONGNAMES As Long = &H40000
  58. Public Const OFN_NONETWORKBUTTON As Long = &H20000
  59. Public Const OFN_NOREADONLYRETURN As Long = &H8000& '*see comments
  60. Public Const OFN_NOTESTFILECREATE As Long = &H10000
  61. Public Const OFN_NOVALIDATE As Long = &H100
  62. Public Const OFN_OVERWRITEPROMPT As Long = &H2
  63. Public Const OFN_PATHMUSTEXIST As Long = &H800
  64. Public Const OFN_READONLY As Long = &H1
  65. Public Const OFN_SHAREAWARE As Long = &H4000
  66. Public Const OFN_SHAREFALLTHROUGH As Long = 2
  67. Public Const OFN_SHAREWARN As Long = 0
  68. Public Const OFN_SHARENOWARN As Long = 1
  69. Public Const OFN_SHOWHELP As Long = &H10
  70. Public Const OFN_ENABLESIZING As Long = &H800000
  71. Public Const OFS_MAXPATHNAME As Long = 260
  72.  
  73. Private Type OPENFILENAME
  74. lStructSize As Long
  75. hWndOwner As LongPtr
  76. hInstance As LongPtr
  77. lpstrFilter As String
  78. lpstrCustomFilter As String
  79. nMaxCustFilter As Long
  80. nFilterIndex As Long
  81. lpstrFile As String
  82. nMaxFile As Long
  83. lpstrFileTitle As String
  84. nMaxFileTitle As Long
  85. lpstrInitialDir As String
  86. lpstrTitle As String
  87. flags As Long
  88. nFileOffset As Integer
  89. nFileExtension As Integer
  90. lpstrDefExt As String
  91. lCustData As Long
  92. lpfnHook As LongPtr
  93. lpTemplateName As String
  94. End Type
  95.  
  96. Public Type BROWSEINFO
  97.         hWndOwner As LongPtr
  98.         pidlRoot As LongPtr
  99.         pszDisplayName As String
  100.         lpszTitle As String
  101.         ulFlags As Long
  102.         lpfnCallback As LongPtr
  103.         lParam As LongPtr
  104.         iImage As Long
  105. End Type
  106.  
  107. '====== Folder Browser for 64 bit VBA 7 ========
  108. Public Function FolderBrowse(ByVal sDialogTitle As String, ByVal sInitFolder As String) As String
  109. Dim ReturnPath As String
  110.  
  111. Dim b(MAX_PATH) As Byte
  112. Dim pItem As LongPtr
  113. Dim sFullPath As String
  114. Dim bi As BROWSEINFO
  115. Dim ppidl As Long
  116.  
  117. sInitFolder = CorrectPath(sInitFolder)
  118.  
  119. ' Note VBA windows and dialogs do not have an hWnd property.
  120. bi.hWndOwner = 0 'Windows Main Screen handle.
  121.  
  122. bi.pidlRoot = 0 'ppidl
  123.  
  124. bi.pszDisplayName = VarPtr(b(0))
  125. bi.lpszTitle = sDialogTitle
  126. bi.ulFlags = BIF_RETURNONLYFSDIRS
  127. If FolderExists(sInitFolder) Then bi.lpfnCallback = PtrToFunction(AddressOf BFFCallback)
  128. bi.lParam = StrPtr(sInitFolder)
  129.  
  130. pItem = SHBrowseForFolder(bi)
  131.  
  132. If pItem Then ' Succeeded
  133. sFullPath = Space$(MAX_PATH)
  134. If SHGetPathFromIDList(pItem, sFullPath) Then
  135. ReturnPath = Left$(sFullPath, InStr(sFullPath, vbNullChar) - 1) ' Strip nulls
  136. CoTaskMemFree pItem
  137. End If
  138. End If
  139.  
  140. If ReturnPath <> "" Then
  141. If Right$(ReturnPath, 1) <> "\" Then
  142. ReturnPath = ReturnPath & "\"
  143. End If
  144. End If
  145.  
  146. FolderBrowse = ReturnPath
  147. End Function
  148.  
  149. ' typedef int (CALLBACK* BFFCALLBACK)(HWND hwnd, UINT uMsg, LPARAM lParam, LPARAM lpData);
  150. Private Function BFFCallback(ByVal hWnd As LongPtr, ByVal uMsg As LongPtr, ByVal lParam As LongPtr, ByVal sData As String) As LongPtr
  151. If uMsg = BFFM_INITIALIZED Then
  152. SendMessageA hWnd, BFFM_SETSELECTIONA, True, ByVal sData
  153. End If
  154. End Function
  155.  
  156. Private Function PtrToFunction(ByVal lFcnPtr As LongPtr) As LongPtr
  157. PtrToFunction = lFcnPtr
  158. End Function
  159.  
  160. Private Function CorrectPath(ByVal sPath As String) As String
  161. If Right$(sPath, 1) = "\" Then
  162. If Len(sPath) > 3 Then sPath = Left$(sPath, Len(sPath) - 1) ' Strip backslash from non-root
  163. Else
  164. If Len(sPath) = 2 Then sPath = sPath & "\" ' Append backslash to root
  165. End If
  166. CorrectPath = sPath
  167. End Function
  168.  
  169. Public Function FolderExists(ByVal sFolderName As String) As Boolean
  170. Dim att As Long
  171. On Error Resume Next
  172. att = GetAttr(sFolderName)
  173. If Err.Number = 0 Then
  174. FolderExists = True
  175. Else
  176. Err.Clear
  177. FolderExists = False
  178. End If
  179. On Error GoTo 0
  180. End Function

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Anatoly,
Спасибо!
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн AnatolyАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 62
  • Карма: 3
  • Skype: ant_nkh
В продолжении темы.
Windows 10, Autocad 2019.
Понадобился диалог выбора файла.
Использовал функцию GetOpenFileName из предыдущего поста
Код - Visual Basic [Выбрать]
  1. Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
  2.     "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
и прежде была функция ShowOpen -использовал ее.
Код - Visual Basic [Выбрать]
  1. Public Const OFN_HIDEREADONLY = &H4
  2. Public Const OFN_ALLOWMULTISELECT = &H200
  3. Public Const OFN_EXPLORER = &H80000
  4. '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
  5. ' Display and use the File open dialog
  6. '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
  7. Public Function ShowOpen() As String
  8. Dim strTemp As String
  9. Dim of As OPENFILENAME
  10. of.lStructSize = Len(of)
  11. of.hWndOwner = ThisDrawing.hWnd
  12. of.lpstrFilter = "Excel files" & vbNullChar & "*.xls;*.xlsm" & vbNullChar & vbNullChar & vbNullChar
  13. of.lpstrFile = space$(256000)
  14. of.nMaxFile = 256001
  15. of.lpstrFileTitle = space$(256000)
  16. of.nMaxFileTitle = 256001
  17. of.lpstrInitialDir = CurDir
  18. of.lpstrTitle = "Âûáîð ôàéëà Excel"
  19. of.flags = OFN_HIDEREADONLY + OFN_EXPLORER ' OFN_HIDEREADONLY + OFN_ALLOWMULTISELECT + OFN_EXPLORER
  20. If GetOpenFileName(of) Then
  21. strTemp = (Trim(of.lpstrFile))
  22. ShowOpen = strTemp
  23.  
  24. End If
  25. End Function

В итоге диалог не открывается.
Видимо дело в of.hWndOwner = ThisDrawing.hWnd
Нужна помощь.

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Видимо дело в of.hWndOwner = ThisDrawing.hWnd
Если дело в этом, то должно быть достаточно заменить ThisDrawing.hWnd на 0.
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн AnatolyАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 62
  • Карма: 3
  • Skype: ant_nkh
Попробовал of.hWndOwner =0. Не помогло.

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Попробовал of.hWndOwner =0. Не помогло.
Значит что-то в других элементах структуры OPENFILENAME не то.
Попробуй с такой структурой:
Код - Visual Basic [Выбрать]
  1. Type OPENFILENAME
  2.         lStructSize As Long
  3.         hwndOwner As LongPtr
  4.         hInstance As LongPtr
  5.         lpstrFilter As String
  6.         lpstrCustomFilter As String
  7.         nMaxCustFilter As Long
  8.         nFilterIndex As Long
  9.         lpstrFile As String
  10.         nMaxFile As Long
  11.         lpstrFileTitle As String
  12.         nMaxFileTitle As Long
  13.         lpstrInitialDir As String
  14.         lpstrTitle As String
  15.         flags As Long
  16.         nFileOffset As Integer
  17.         nFileExtension As Integer
  18.         lpstrDefExt As String
  19.         lCustData As LongPtr
  20.         lpfnHook As LongPtr
  21.         lpTemplateName As String
  22.         pvReserved As LongPtr
  23.         dwReserved As Long
  24.         FlagsEx As Long
  25. End Type
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Еще немного погуглил и нашел эту тему: https://www.sql.ru/forum/1307493/getopenfilename-v-64-h-bitnyh-versiyah
Оттуда вместо:
Код - Visual Basic [Выбрать]
  1. of.lStructSize = Len(of)
должно быть:
Код - Visual Basic [Выбрать]
  1. of.lStructSize = LenB(of)
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн AnatolyАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 62
  • Карма: 3
  • Skype: ant_nkh
На Windows 7 и 10 заработало.
Большое спасибо!
« Последнее редактирование: 26-02-2021, 09:34:29 от Anatoly »

Отмечено как Решение Anatoly 26-02-2021, 09:41:28

Оффлайн AnatolyАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 62
  • Карма: 3
  • Skype: ant_nkh
Диалог выбора папки или файла
Код - Visual Basic [Выбрать]
  1.     Option Explicit
  2.     '----------------------------------------------------------------------
  3.    ' 64 bit VBA 7 version of File and Folder Browswers
  4.    ' FileBrowseOpen() ' FileBrowseSave() ' FolderBrowse()
  5.    '----------------------------------------------------------------------
  6.    
  7.     Public Declare PtrSafe Function SendMessageA Lib "user32" _
  8.     (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
  9.      
  10.     Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
  11.     Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr
  12.      
  13.     Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
  14.     Alias "SHGetPathFromIDListA" (ByVal pidList As LongPtr, ByVal lpBuffer As String) As Boolean
  15.      
  16.     Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As LongPtr)
  17.      
  18.     Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
  19.     "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
  20.      
  21.     Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
  22.     "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
  23.      
  24.     Private Const BIF_RETURNONLYFSDIRS As Long = 1
  25.     Private Const CSIDL_DRIVES As Long = &H11
  26.     Private Const WM_USER As Long = &H400
  27.     Private Const MAX_PATH As Long = 260
  28.      
  29.     '// message from browser
  30.    Private Const BFFM_INITIALIZED As Long = 1
  31.     Private Const BFFM_SELCHANGED As Long = 2
  32.     Private Const BFFM_VALIDATEFAILEDA As Long = 3 '// lParam:szPath ret:1(cont),0(EndDialog)
  33.    Private Const BFFM_VALIDATEFAILEDW As Long = 4 '// lParam:wzPath ret:1(cont),0(EndDialog)
  34.    Private Const BFFM_IUNKNOWN As Long = 5 '// provides IUnknown to client. lParam: IUnknown*
  35.    
  36.     '// messages to browser
  37.    Private Const BFFM_SETSTATUSTEXTA As Long = WM_USER + 100
  38.     Private Const BFFM_ENABLEOK As Long = WM_USER + 101
  39.     Private Const BFFM_SETSELECTIONA As Long = WM_USER + 102
  40.     Private Const BFFM_SETSELECTIONW As Long = WM_USER + 103
  41.     Private Const BFFM_SETSTATUSTEXTW As Long = WM_USER + 104
  42.     Private Const BFFM_SETOKTEXT As Long = WM_USER + 105 '// Unicode only
  43.    Private Const BFFM_SETEXPANDED As Long = WM_USER + 106 '// Unicode only
  44.    
  45.     Public Const OFN_ALLOWMULTISELECT As Long = &H200
  46.     Public Const OFN_CREATEPROMPT As Long = &H2000
  47.     Public Const OFN_ENABLEHOOK As Long = &H20
  48.     Public Const OFN_ENABLETEMPLATE As Long = &H40
  49.     Public Const OFN_ENABLETEMPLATEHANDLE As Long = &H80
  50.     Public Const OFN_EXPLORER As Long = &H80000
  51.     Public Const OFN_EXTENSIONDIFFERENT As Long = &H400
  52.     Public Const OFN_FILEMUSTEXIST As Long = &H1000
  53.     Public Const OFN_HIDEREADONLY As Long = &H4
  54.     Public Const OFN_LONGNAMES As Long = &H200000
  55.     Public Const OFN_NOCHANGEDIR As Long = &H8
  56.     Public Const OFN_NODEREFERENCELINKS As Long = &H100000
  57.     Public Const OFN_NOLONGNAMES As Long = &H40000
  58.     Public Const OFN_NONETWORKBUTTON As Long = &H20000
  59.     Public Const OFN_NOREADONLYRETURN As Long = &H8000& '*see comments
  60.    Public Const OFN_NOTESTFILECREATE As Long = &H10000
  61.     Public Const OFN_NOVALIDATE As Long = &H100
  62.     Public Const OFN_OVERWRITEPROMPT As Long = &H2
  63.     Public Const OFN_PATHMUSTEXIST As Long = &H800
  64.     Public Const OFN_READONLY As Long = &H1
  65.     Public Const OFN_SHAREAWARE As Long = &H4000
  66.     Public Const OFN_SHAREFALLTHROUGH As Long = 2
  67.     Public Const OFN_SHAREWARN As Long = 0
  68.     Public Const OFN_SHARENOWARN As Long = 1
  69.     Public Const OFN_SHOWHELP As Long = &H10
  70.     Public Const OFN_ENABLESIZING As Long = &H800000
  71.     Public Const OFS_MAXPATHNAME As Long = 260
  72.      
  73.         Type OPENFILENAME
  74.             lStructSize As Long
  75.             hwndOwner As LongPtr
  76.             hInstance As LongPtr
  77.             lpstrFilter As String
  78.             lpstrCustomFilter As String
  79.             nMaxCustFilter As Long
  80.             nFilterIndex As Long
  81.             lpstrFile As String
  82.             nMaxFile As Long
  83.             lpstrFileTitle As String
  84.             nMaxFileTitle As Long
  85.             lpstrInitialDir As String
  86.             lpstrTitle As String
  87.             flags As Long
  88.             nFileOffset As Integer
  89.             nFileExtension As Integer
  90.             lpstrDefExt As String
  91.             lCustData As LongPtr
  92.             lpfnHook As LongPtr
  93.             lpTemplateName As String
  94.             pvReserved As LongPtr
  95.             dwReserved As Long
  96.             FlagsEx As Long
  97.     End Type
  98.      
  99.     Public Type BROWSEINFO
  100.             hwndOwner As LongPtr
  101.             pidlRoot As LongPtr
  102.             pszDisplayName As String
  103.             lpszTitle As String
  104.             ulFlags As Long
  105.             lpfnCallback As LongPtr
  106.             lParam As LongPtr
  107.             iImage As Long
  108.     End Type
  109.      
  110.     '====== Folder Browser for 64 bit VBA 7 ========
  111.    ' call: fold = FolderBrowse("", fldnam) ' full path
  112.    ' fldnam: start path
  113.    
  114.     Public Function FolderBrowse(ByVal sDialogTitle As String, ByVal sInitFolder As String) As String
  115.     Dim ReturnPath As String
  116.      
  117.     Dim b(MAX_PATH) As Byte
  118.     Dim pItem As LongPtr
  119.     Dim sFullPath As String
  120.     Dim bi As BROWSEINFO
  121.     Dim ppidl As Long
  122.      
  123.     sInitFolder = CorrectPath(sInitFolder)
  124.      
  125.     ' Note VBA windows and dialogs do not have an hWnd property.
  126.    bi.hwndOwner = 0 'Windows Main Screen handle.
  127.    
  128.     bi.pidlRoot = 0 'ppidl
  129.    
  130.     bi.pszDisplayName = VarPtr(b(0))
  131.     bi.lpszTitle = sDialogTitle
  132.     bi.ulFlags = BIF_RETURNONLYFSDIRS
  133.     If FolderExists(sInitFolder) Then bi.lpfnCallback = PtrToFunction(AddressOf BFFCallback)
  134.     bi.lParam = StrPtr(sInitFolder)
  135.      
  136.     pItem = SHBrowseForFolder(bi)
  137.      
  138.     If pItem Then ' Succeeded
  139.    sFullPath = space$(MAX_PATH)
  140.     If SHGetPathFromIDList(pItem, sFullPath) Then
  141.     ReturnPath = Left$(sFullPath, InStr(sFullPath, vbNullChar) - 1) ' Strip nulls
  142.    CoTaskMemFree pItem
  143.     End If
  144.     End If
  145.      
  146.     If ReturnPath <> "" Then
  147.     If Right$(ReturnPath, 1) <> "\" Then
  148.     ReturnPath = ReturnPath & "\"
  149.     End If
  150.     End If
  151.      
  152.     FolderBrowse = ReturnPath
  153.     End Function
  154.      
  155.     '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
  156.    ' Display and use the File open dialog
  157.    ' call  strFileName = ShowOpen()
  158.    ' Public strFileName As String        ' full path
  159.    '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
  160.    Public Function ShowOpen() As String
  161.     Dim strTemp As String
  162.     Dim of As OPENFILENAME
  163.     of.lStructSize = LenB(of)
  164.     of.hwndOwner = 0
  165.     of.lpstrFilter = "Excel files" & vbNullChar & "*.xlsx;*.xlsm" & vbNullChar & vbNullChar & vbNullChar
  166.     of.lpstrFile = space$(256000)
  167.     of.nMaxFile = 256001
  168.     of.lpstrFileTitle = space$(256000)
  169.     of.nMaxFileTitle = 256001
  170.     of.lpstrInitialDir = CurDir
  171.     of.lpstrTitle = "Excel files selection"
  172.     of.flags = OFN_HIDEREADONLY + OFN_EXPLORER ' OFN_HIDEREADONLY + OFN_ALLOWMULTISELECT + OFN_EXPLORER
  173.    If GetOpenFileName(of) Then
  174.      strTemp = (Trim(of.lpstrFile))
  175.      ShowOpen = strTemp
  176.     End If
  177.     End Function
  178.  
  179.     ' typedef int (CALLBACK* BFFCALLBACK)(HWND hwnd, UINT uMsg, LPARAM lParam, LPARAM lpData);
  180.    Private Function BFFCallback(ByVal hWnd As LongPtr, ByVal uMsg As LongPtr, ByVal lParam As LongPtr, ByVal sData As String) As LongPtr
  181.     If uMsg = BFFM_INITIALIZED Then
  182.     SendMessageA hWnd, BFFM_SETSELECTIONA, True, ByVal sData
  183.     End If
  184.     End Function
  185.      
  186.     Private Function PtrToFunction(ByVal lFcnPtr As LongPtr) As LongPtr
  187.     PtrToFunction = lFcnPtr
  188.     End Function
  189.      
  190.     Private Function CorrectPath(ByVal sPath As String) As String
  191.     If Right$(sPath, 1) = "\" Then
  192.     If Len(sPath) > 3 Then sPath = Left$(sPath, Len(sPath) - 1) ' Strip backslash from non-root
  193.    Else
  194.     If Len(sPath) = 2 Then sPath = sPath & "\" ' Append backslash to root
  195.    End If
  196.     CorrectPath = sPath
  197.     End Function
  198.      
  199.     Public Function FolderExists(ByVal sFolderName As String) As Boolean
  200.     Dim att As Long
  201.     On Error Resume Next
  202.     att = GetAttr(sFolderName)
  203.     If Err.Number = 0 Then
  204.     FolderExists = True
  205.     Else
  206.     Err.Clear
  207.     FolderExists = False
  208.     End If
  209.     On Error GoTo 0
  210.     End Function
  211.  
  212.