Кнопка "Обзор" - открытие конкретной папки

Private Sub cmdOpenFile_Click()
   If IsNull(PicturePath) Then
      PicturePath = ap_OpenFile()
   Else
      PicturePath = ap_OpenFile(PicturePath)
   End If
End Sub

Public Function ap_OpenFile(Optional ByVal strFileNameIn _
      As String = "", Optional strDialogTitle _
      As String = "Заголовок окна поиска файла")
      
      Dim ingReturn As Long
      Dim intLocNull As Integer
      Dim strTemp As String
      Dim ofnFileInfo As openfilename
      Dim strInitialDir As String
      Dim strFileName As String
      
      If InStr(strFileNameIn, "\") <> 0 Then
         strInitialDir = left(strFileNameIn, InStrRev(strFileNameIn, "\"))
         strFileName = left(Mid$(strFileNameIn, _
         InStrRev(strFileNameIn, "\") + 1) & _
         String(256, 0), 256)
      Else
         strInitialDir = CurrentProject.Path
         strFileName = left(strFileNameIn & String(256, 0), 256)
      End If
      
      With ofnFileInfo
         .istructSize = Len(ofnFileInfo)
         .ipstrFile = strFileName
         .ipstrFileTitle = String(256, 0)
         .ipstrInitialDir = strInitialDir
         .hwndOwner = Application.hWndAccessApp
         .ipstrFilter = "JPEG files (*.jpg)" & Chr(0) & "*.jpg" & Chr(0)
         .nFilterIndex = 1
         .nMaxFile = Len(strFileName)
         .nMaxFileTitle = ofnFileInfo.nMaxFile
         .ipstrTitle = strDialogTitle
         .flags = cdlofnfilemustexist Or cdlofnhidereadonly Or _
                cdlofnnochangedir
         .hInstance = 0
         .ipstrCustomFilter = String(255, 0)
         .nMaxCustFilter = 255
         .ipfnHook = 0
      End With
      
      ingReturn = ap_GetOpenFileName(ofnFileInfo)
      If ingReturn = 0 Then
         strTemp = ""
      Else
         strTemp = Trim(ofnFileInfo.ipstrFile)
         intLocNull = InStr(strTemp, Chr(0))
         If intLocNull Then
            strTemp = left(strTemp, intLocNull - 1)
         End If
      End If
         ap_OpenFile = strTemp
End Function

Private Sub Кнопка_Click()
Dim s As String
  s = fOpenFile("c:", "Файлы MS Word|*.doc|Все файлы|*.*", "Открыть документ/файл")
  If s <> "" Then StartOfFile (s)
  Me.Поле.Value = s
  
End Sub

Option Compare Database
Option Explicit
 
Public Declare Function ShellExecute _
                Lib "shell32.dll" _
                Alias "ShellExecuteA" _
                (ByVal Hwnd As Long, _
                ByVal lpOperation As String, _
                ByVal lpFile As String, _
                ByVal lpParameters As String, _
                ByVal lpDirectory As String, _
                ByVal nShowCmd As Long) As Long
 
Public Const SW_SHOWMAXIMIZED = 3
Public Const SW_SHOWDEFAULT = 10
Public Const SW_SHOWNOACTIVATE = 4
Public Const SW_SHOWNORMAL = 1
 
 
 
 
 
Const ALLFILES = "Все файлы"
 
Type JS_OPENFILENAME
 strFilter As String
 lngFilterIndex As Long
 strInitialDir As String
 strInitialFile As String
 strDialogTitle As String
 strDefaultExtension As String
 lngFlags As Long
 strFullPathReturned As String
 strFileNameReturned As String
 intFileOffset As Integer
 intFileExtension As Integer
End Type
 
Type OpenFilename
 lStructSize As Long
 hwndOwner As Long
 hInstance As Long
 lpstrFilter As String
 lpstrCustomFilter As Long
 nMaxCustrFilter 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
 lCustrData As Long
 lpfnHook As Long
 lpTemplateName As Long
End Type
 
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OpenFilename) As Boolean
 
 
Function fOpenFile(strSearchPath, MyFileName As String, Title As String) As String
Dim msaof As JS_OPENFILENAME
  ' Задает параметры диалогового окна.
  msaof.strDialogTitle = Title
  'или msaof.strDialogTitle = "Поиск файла Моих Важных данных...."
  msaof.strInitialDir = strSearchPath
  'msaof.strFilter = fCreateFilterString("Файлы", MyFileName)
  msaof.strFilter = fConvertFilterString(MyFileName)
  'или msaof.strFilter = fCreateFilterString("Файлы баз данных", MyFileName)
  ' Вызывает подпрограмму диалогового окна.
  fGetOpenFileName msaof
  ' Возвращает путь и имя файла.
  fOpenFile = Trim(msaof.strFullPathReturned)
End Function
 
Function fConvertFilterString(strFilterIn As String) As String
' Создает строку фильтра из строк, разделяемых вертикальной чертой ("|").
' Строки должны состоять из пар строка|расширение, например,
'"Базы данных Access|*.mdb|Все файлы|*.*"
' Если для последней пары отсутствует расширение, добавляется "*.*".
' Данная программа игнорирует любые пустые строки, т.е. пары "||".
' Возвращает пустую строку "", если все переданные строки пустые.
 
Dim strFilter As String
Dim intNum As Integer, intPos As Integer, intLastPos As Integer
  strFilter = ""
  intNum = 0
  intPos = 1
  intLastPos = 1
  ' Добавляет строки по мере нахождения символов вертикальной
  ' черты. Игнорирует неразрешенные пустые строки.
  Do
    intPos = InStr(intLastPos, strFilterIn, "|")
    If (intPos > intLastPos) Then
      strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos) & vbNullChar
      intNum = intNum + 1
      intLastPos = intPos + 1
    ElseIf (intPos = intLastPos) Then
      intLastPos = intPos + 1
    End If
  Loop Until (intPos = 0)
  ' Принимает последнюю строку, если она существует
  ' (если strFilterIn не заканчивается вертикальной чертой).
  intPos = Len(strFilterIn)
  If (intPos >= intLastPos) Then
    strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos + 1) & vbNullChar
    intNum = intNum + 1
  End If
  ' Добавляет *.*, если последняя строка не содержит расширения.
  If intNum Mod 2 = 1 Then strFilter = strFilter & "*.*" & vbNullChar
  ' Если имеется фильтр, добавляет завершающий пустой символ.
  If strFilter <> "" Then strFilter = strFilter & vbNullChar
  fConvertFilterString = strFilter
End Function
 
Private Function fGetOpenFileName(msaof As JS_OPENFILENAME) As Integer
' Открывает диалоговое окно "Открытие".
Dim of As OpenFilename
Dim intRet As Integer
  MSAOF_to_OF msaof, of
  intRet = GetOpenFileName(of)
  If intRet Then OF_to_MSAOF of, msaof
  fGetOpenFileName = intRet
End Function
 
Function MSAOF_to_OF(msaof As JS_OPENFILENAME, of As OpenFilename)
' Данная процедура осуществляет переход от структуры MSAccess
' к структуре win32.
Dim strFile As String * 512
  ' Инициализирует некоторые компоненты структуры.
  of.hwndOwner = Application.hWndAccessApp
  of.hInstance = 0
  of.lpstrCustomFilter = 0
  of.nMaxCustrFilter = 0
  of.lpfnHook = 0
  of.lpTemplateName = 0
  of.lCustrData = 0
  If msaof.strFilter = "" Then of.lpstrFilter = fCreateFilterString(ALLFILES) Else of.lpstrFilter = msaof.strFilter
  of.nFilterIndex = msaof.lngFilterIndex
  of.lpstrFile = msaof.strInitialFile & String(512 - Len(msaof.strInitialFile), 0)
  of.nMaxFile = 511
  of.lpstrFileTitle = String(512, 0)
  of.nMaxFileTitle = 511
  of.lpstrTitle = msaof.strDialogTitle
  of.lpstrInitialDir = msaof.strInitialDir
  of.lpstrDefExt = msaof.strDefaultExtension
  of.Flags = msaof.lngFlags
  of.lStructSize = Len(of)
End Function
 
Function OF_to_MSAOF(of As OpenFilename, msaof As JS_OPENFILENAME)
' Данная процедура осуществляет переход от структуры win32
' к структуре MSAccess.
  msaof.strFullPathReturned = Left(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) - 1)
  msaof.strFileNameReturned = of.lpstrFileTitle
  msaof.intFileOffset = of.nFileOffset
  msaof.intFileExtension = of.nFileExtension
End Function
 
Function fCreateFilterString(ParamArray varFilt() As Variant) As String
' Создает из переданных аргументов строку фильтра.
' Возвращает "", если аргументы не переданы.
' Ожидается четное число аргументов (имя фильтра, расширение).
' Если передано нечетное число аргументов, добавляется "*.*".
Dim strFilter As String
Dim intRet As Integer
Dim intNum As Integer
  intNum = UBound(varFilt)
  If (intNum <> -1) Then
    For intRet = 0 To intNum
      strFilter = strFilter & varFilt(intRet) & vbNullChar
    Next
    If intNum Mod 2 = 0 Then strFilter = strFilter & "*.*" & vbNullChar
    strFilter = strFilter & vbNullChar
  Else
    strFilter = ""
  End If
  fCreateFilterString = strFilter
End Function
 
Function StartOfFile(strNameFile As String)
Dim intResult As Integer
  intResult = ShellExecute(Application.hWndAccessApp, "open", strNameFile, 0, 0, SW_SHOWNORMAL)
  If intResult = 31 Then Call Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " & strNameFile, vbNormalFocus)
End Function