Диалог открытия файлов-данные о папках

Option Compare Database
Option Explicit
Declare Function GetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
Declare Function GetSaveFileName Lib "comdlg32.dll" _
Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Boolean

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

Public Const OFN_ALLOWMULTISELECT = &H200
Public Const OFN_CREATEPROMPT = &H2000
Public Const OFN_EXPLORER = &H80000
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_NOCHANGEDIR = &H8
Public Const OFN_NODEREFERENCELINKS = &H100000
Public Const OFN_NONETWORKBUTTON = &H20000
Public Const OFN_NOREADONLYRETURN = &H8000
Public Const OFN_NOVALIDATE = &H100
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_READONLY = &H1
Public Const OFN_SHOWHELP = &H10

Public Function OpenFile(ByVal InitDir As String, ByVal fname As String) As String
Dim strFile As String * 512
Dim of As OPENFILENAME
Dim f As String
Dim p%
' Óñòàíîâêà íà÷àëüíûõ çíà÷åíèé ñòðóêòóðû
of.hwndOwner = Application.hWndAccessApp
of.hInstance = 0
of.lpstrCustomFilter = 0
of.nMaxCustrFilter = 0
of.lpfnHook = 0
of.lpTemplateName = 0
of.lCustrData = 0
'Íèæå âû ìîæåòå èçìåíèòü ôèëüòðû äëÿ ïîèñêà ôàéëîâ
of.lpstrFilter = "MS Word Database (*.doc)" & Chr$(0) & "*.doc" & Chr$(0) & _
"Excel (*.xls)" & Chr$(0) & "*.xls" & Chr$(0) & _
".. (..)" & Chr$(0) & ".." & Chr$(0) & _
"All Files (*.*)" & Chr$(0) & "*.*" & Chr$(0) & Chr$(0)

of.nFilterIndex = 3

of.lpstrFile = fname & String$(512 - Len(fname), 0)
of.nMaxFile = 511

of.lpstrFileTitle = String$(512, 0)
of.nMaxFileTitle = 511
' Íèæå âû ìîæåòå èçìåíèòü çàãîëîâîê îêíà
of.lpstrTitle = "Îòêðûòü ìîäóëü"

of.lpstrInitialDir = InitDir
' Ìîæåòå èçìåíèòü ðàñøèðåíèå ôàéëà
'of.lpstrDefExt = "mde"
'of.Flags = OFN_FILEMUSTEXIST + OFN_PATHMUSTEXIST
'of.Flags = OFN_FILEMUSTEXIST + OFN_PATHMUSTEXIST  + OFN_ALLOWMULTISELECT ' - ìíîãî ôàéëîâ ÷åðåç ïðîáåë
of.Flags = OFN_FILEMUSTEXIST + OFN_PATHMUSTEXIST + OFN_HIDEREADONLY
of.lStructSize = Len(of)
If GetOpenFileName(of) Then
p% = InStr(1, of.lpstrFile, Chr$(0))
OpenFile = Left(of.lpstrFile, p% - 1)
Else
OpenFile = ""
End If
End Function

Private Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type

Private Const BIF_RETURNONLYFSDIRS = &H1
Public Const OFN_EXPLORER = &H80000 '  new look commdlg
Public Const OFN_NOCHANGEDIR = &H8

Private Declare Function SHBrowseForFolder Lib "shell32.dll"
 Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" 
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Public Function BrowseFolder(szDialogTitle As String) As String
 Dim x As Long, bi As BROWSEINFO, dwIList As Long
 Dim szPath As String, wPos As Integer

 With bi
  .hOwner = hWndAccessApp
  .lpszTitle = szDialogTitle
  .ulFlags = BIF_RETURNONLYFSDIRS
 End With

 dwIList = SHBrowseForFolder(bi)
 szPath = Space$(512)
 x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)

 If x Then
  wPos = InStr(szPath, Chr(0))
  BrowseFolder = Left$(szPath, wPos - 1)
 Else
  BrowseFolder = ""
 End If
End Function

Private Sub Btn_Path_Click()
Dim FName As String
Dim result As Integer
With Application.FileDialog(1) ' вместо : With Application.FileDialog(msoFileDialogOpen) '
    .Title = "Select picture"

    .InitialFileName = "C:\" 'default path'
    .AllowMultiSelect = False
    .Filters.Clear
    .Filters.Add "Picture files", "*.bmp; *.jpg", 1
    result = .Show

    If result = 0 Then Exit Sub
    FName = Trim(.SelectedItems.Item(1)) 
End With
on error resume next
me.imageObj.Picture = FName
End Sub