Option Explicit
'^*^*^*^*^*^*^*^*^*^*^*^*^*
'> Folder/File browsing code module
'^*^*^*^*^*^*^*^*^*^*^*^*^*
'Retrieves the window handle to the active window associated with the thread that calls the function
Private Declare Function apiGetActiveWindow& Lib "user32" Alias "GetActiveWindow" ()
'Retrieves a handle to the specified child window's parent window
Private Declare Function apiGetParent& Lib "user32" Alias "GetParent" _
(ByVal hWnd As Long)
'Retrieves the dimensions of the bounding rectangle of the specified window
Private Declare Function GetWindowRect& Lib "user32" _
(ByVal hWnd As Long, _
lpRect As RECT)
'Retrieves various system metrics (in pixels)
Private Declare Function GetSystemMetrics& Lib "user32" _
(ByVal nIndex As Long)
'Changes the position and dimensions of the specified window
Private Declare Function MoveWindow& Lib "user32" _
(ByVal hWnd As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Long)
'Appends one string to another
Private Declare Function lstrcat& Lib "kernel32.dll" Alias "lstrcatA" _
(ByVal lpString1 As String, _
ByVal lpString2 As String)
'Displays a dialog box enabling the user to select a Shell folder
Private Declare Function SHBrowseForFolder& Lib "shell32.dll" _
(lpbi As BrowseInfo)
'Converts an item identifier list to a file system path
Private Declare Function SHGetPathFromIDList& Lib "shell32.dll" _
(ByVal pidList As Long, _
ByVal lpBuffer As String)
'Retrieves a pointer to the ITEMIDLIST structure of a special folder
Private Declare Function SHGetSpecialFolderLocation& Lib "shell32.dll" _
(ByVal hWndOwner As Long, _
ByVal nFolder As Long, _
ppidl As Long)
'Retrieves a handle to a window whose class name and window name match the specified strings
Private Declare Function FindWindowEx& Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String)
'Retrieves the identifier of the thread that created the specified window
Private Declare Function GetWindowThreadProcessId& Lib "user32" _
(ByVal hWnd As Long, _
ByRef lpdwProcessId As Long)
'Retrieves the process identifier of the calling process
Private Declare Function GetCurrentProcessId& Lib "kernel32" ()
'Returns a handle to the desktop window
Private Declare Function GetDesktopWindow& Lib "user32" ()
'Frees a block of task memory
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
'Parameters for the dialog centering
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'Parameters for the SHBrowseForFolder function
Private 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
'Special Folder Types
Public Enum FolderType
AppData = &H1A
BitBucket = &HA
CommonDesktopDirectory = &H19
CommonDocuments = &H2E
CommonFavorites = &H1F
CommonPrograms = &H17
CommonStartMenu = &H16
CommonStartup = &H18
CommonTemplates = &H2D
CommonAltStartup = &H1E
CommonAppData = &H23
CommonDesktop = &H0
CommonMyMusic = &H35
CommonMyPictures = &H36
CommonMyVideos = &H37
CommonStartAdmin = &H2F
Connections = &H31
Controls = &H3
Drives = &H11
Favorites = &H6
Fonts = &H14
LocalAltStartup = &H1D
LocalAppData = &H1C
LocalAppMSCDBurning = &H3B
LocalCookies = &H21
LocalDesktop = &H10
LocalHistory = &H22
LocalInternetCache = &H20
LocalMyVideos = &HE
LocalStartAdmin = &H30
MSHome = &H3D
MyMusic = &HD
MyPictures = &H27
NetHood = &H13
Network = &H12
Personal = &H5
Printers = &H4
Printhood = &H1B
Profile = &H28
ProgramFiles = &H26
CommonProgramFiles = &H2B
CommonX86ProgramFiles = &H2C
X86ProgramFiles = &H2A
Programs = &H2
Recent = &H8
Resources = &H39
SendTo = &H9
StartMenu = &HB
Startup = &H7
System = &H25
SystemX86 = &H29
Templates = &H15
Windows = &H24
End Enum
'What to browse for
Public Enum BrowseType
BrowseForComputers = &H1000
BrowseForPrinters = &H2000
BrowseForFiles = &H4000
BrowseForFilesCreateOption = &H4040
BrowseForFoldersWithEditBox = &H10
BrowseForFoldersCreateOption = &H40
BrowseForFolders = &H1
End Enum
'Screen metric constants
Private Const SM_CXFULLSCREEN = &H10
Private Const SM_CYFULLSCREEN = &H11
'Dialog fully initiallized constant
Private Const BFFM_INITIALIZED = &H1
'Maximum character length of path
Private Const MAX_PATH As Long = 260
Private Function GetAccesshWnd()
Dim hWnd As Long
Dim hWndAccess As Long
' Get the handle to the currently active window.
hWnd = apiGetActiveWindow()
hWndAccess = hWnd
' Find the top window (which has no parent window).
While hWnd <> 0
hWndAccess = hWnd
hWnd = apiGetParent(hWnd)
Wend
GetAccesshWnd = hWndAccess
End Function
Private Function BrowseCallBackFunc(ByVal hWnd As Long, ByVal lMsg As Long, ByVal lParam As Long, ByVal pData As Long) As Long
' Windows calls this function when the dialog events occur
Select Case lMsg
Case BFFM_INITIALIZED
CenterDialog hWnd
End Select
'Allow the dialog to close
BrowseCallBackFunc = 0
End Function
Private Function BrowseCallBackFuncAddress() As Long
BrowseCallBackFuncAddress = Long2Long(AddressOf BrowseCallBackFunc)
End Function
Private Function Long2Long(x As Long) As Long
'Explicitly convert a udt to a long
Long2Long = x
End Function
Private Function fValidatePath(ByVal szFullPath As String) As String
'Check the folder path and add a seperator if necessary
Select Case Right$(szFullPath, 1)
Case ""
Exit Function
Case "\"
fValidatePath = szFullPath
Case Else
fValidatePath = szFullPath & "\"
End Select
End Function
Private Sub CenterDialog(hWnd As Long)
'Used to center the dialog on the screen
Dim WinRect As RECT
Dim ScrWidth As Integer
Dim ScrHeight As Integer
Dim DlgWidth As Integer
Dim DlgHeight As Integer
GetWindowRect hWnd, WinRect
DlgWidth = WinRect.Right - WinRect.Left
DlgHeight = WinRect.Bottom - WinRect.Top
ScrWidth = GetSystemMetrics(SM_CXFULLSCREEN)
ScrHeight = GetSystemMetrics(SM_CYFULLSCREEN)
MoveWindow hWnd, (ScrWidth - DlgWidth) / 2, (ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1
End Sub
Public Function fBrowseFor(ByVal BrowseFor As BrowseType, _
ByVal RootFolder As FolderType, _
Optional bCenter As Boolean) As String
Dim iNullpos As Integer
Dim lpIDList As Long
Dim lres As Long
Dim szPath As String
Dim BInfo As BrowseInfo
Dim lRootID As Long
'Foolproof way to find the main Access window handle
Dim AppWnd As Long
' If Val(Application.Version) >= 10 Then
' AppWnd = Application.hWndAccessApp
' Else
AppWnd = GetAccesshWnd()
' End If
'Retrieve special folder locations
SHGetSpecialFolderLocation AppWnd, RootFolder, lRootID
With BInfo
.hWndOwner = AppWnd
If bCenter Then .lpfnCallback = BrowseCallBackFuncAddress
.ulFlags = BrowseFor
'Determine our browse title
Select Case BrowseFor
Case 1
.lpszTitle = lstrcat("Select a Folder", "")
Case 64
.lpszTitle = lstrcat("Select a Folder", "")
Case 4096
.lpszTitle = lstrcat("Select a Computer", "")
Case 8192
.lpszTitle = lstrcat("Select a Printer", "")
Case Else
.lpszTitle = lstrcat("Select a File", "")
End Select
End With
If lRootID <> 0 Then BInfo.pIDLRoot = lRootID
lpIDList = SHBrowseForFolder(BInfo)
If lpIDList <> 0 Then
szPath = String(MAX_PATH, 0)
lres = SHGetPathFromIDList(lpIDList, szPath)
Call CoTaskMemFree(lpIDList)
iNullpos = InStr(szPath, vbNullChar)
If iNullpos <> 0 Then
szPath = Left$(szPath, iNullpos - 1)
End If
End If
'Browsing for files allow folders to be selected also
'We check the selected item to see if it is a file or not
If Not Mid$(Right$(szPath, 4), 1, 1) = "." Then
fBrowseFor = fValidatePath(szPath)
Else
fBrowseFor = szPath
End If
End Function
