Private Type OFNOTIFY
    hdr As NMHDR
    lpOFN As OPENFILENAME
    pszFile As String
End Type

Option Explicit: Option Base 0: Option Compare Binary
    
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)
Private Declare Function GetOpenFileName Lib "comdlg32" Alias "GetOpenFileNameW" (pOpenFileName As OPENFILENAME) As Long

Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As Long 'String
    lpstrCustomFilter As Long 'String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As Long 'String
    nMaxFile As Long
    lpstrFileTitle As Long 'String
    nMaxFileTitle As Long
    lpstrInitialDir As Long 'String
    lpstrTitle As Long 'String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As Long 'String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As Long 'String
    pvReserved As Long
    dwReserved As Long
    FlagsEx As Long
End Type

Private Type NMHDR
    hwndFrom As Long
    idfrom As Long
    code As Long
End Type

Private Type OFNOTIFY
    hdr As NMHDR
    lpOFN As Long 'OPENFILENAME
    pszFile As Long 'String
End Type

Const WM_NOTIFY = &H4E
Const CDN_FIRST = -601&
Const CDN_TYPECHANGE = (CDN_FIRST - 6&)

Const OFN_ENABLEHOOK = &H20
Const OFN_ENABLESIZING = &H800000
Const OFN_EXPLORER = &H80000
Const OFN_HIDEREADONLY = &H4
Const OFN_LONGNAMES = &H200000
Const OFN_NOVALIDATE = &H100
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_PATHMUSTEXIST = &H800

Private Function GetAddressOfFunction(ByVal Adr As Long) As Long
    GetAddressOfFunction = Adr
End Function

Private Function MyHookProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 Dim oHead As NMHDR
 Dim oNotify As OFNOTIFY
 If uMsg = WM_NOTIFY Then
     ' заголовок события
     CopyMemory oHead, ByVal lParam, LenB(oHead)
     ' изменили тип файлов
     If oHead.code = CDN_TYPECHANGE Then
         ' параметры события
         CopyMemory oNotify, ByVal lParam, LenB(oNotify) ' тут Word схлопывается сразу !!!
         Dim oOFN As OPENFILENAME
         CopyMemory oOFN.lStructSize, ByVal oNotify.lpOFN, LenB(oOFN.lStructSize)
         CopyMemory oOFN, ByVal oNotify.lpOFN, oOFN.lStructSize
     End If
 End If
End Function

Function API_SelectFolderDlg() As Long
 Dim OFN As OPENFILENAME
 OFN.hwndOwner = GetActiveWindow()
 OFN.hInstance = 0
 OFN.flags = OFN_EXPLORER _
          Or OFN_ENABLESIZING _
          Or OFN_LONGNAMES _
          Or OFN_HIDEREADONLY _
          Or OFN_PATHMUSTEXIST _
          Or OFN_NOVALIDATE _
          Or OFN_ENABLEHOOK
 OFN.lpfnHook = GetAddressOfFunction(AddressOf MyHookProc)
 OFN.lpstrFilter = StrPtr("Все файлы" & vbNullChar & "*.*" & vbNullChar & _
                   "Документы Word" & vbNullChar & "*.DOCX;*.DOCM;*.DOC;*.RTF" & vbNullChar & _
                   vbNullChar)
 OFN.nFilterIndex = 1
 OFN.lpstrInitialDir = 0 'vbNullChar
 Dim strFile As String
 strFile = String$(4096, vbNullChar)
 OFN.lpstrFile = StrPtr(strFile)
 OFN.nMaxFile = 4096
 OFN.lStructSize = LenB(OFN)
 GetOpenFileName OFN
End Function

Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
   Dest As Any, Src As Any, ByVal cb As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" ( _
   ByVal psString As Any) As Long

Public Function LPWSTR2String(ByVal lpWStr As Long) As String
 Dim nStrLen As Long
 If lpWStr Then
    nStrLen = lstrlenW(lpWStr)
    LPWSTR2String = String$(nStrLen, vbNullChar)
    CopyMemory ByVal StrPtr(LPWSTR2String), ByVal lpWStr, nStrLen * 2
 Else
    LPWSTR2String = vbNullString
 End If
End Function

         Dim oOFN As OPENFILENAME
         CopyMemory oOFN.lStructSize, ByVal oNotify.lpOFN, LenB(oOFN.lStructSize)
         CopyMemory oOFN, ByVal oNotify.lpOFN, oOFN.lStructSize