Rob4077
asked on
Allow creation and/or selection of folder
I found the following question contained some code from ryancys that apparently worked well at the time. I have tried it on my machine and the display it gives is perfect but when I try to select a folder it causes MS Access 2003 to crash. Can anyone provide me with either an alternative solution or a fix for the code? What I need is to be able to allow the user to select a subfolder to install some files and if the folder doesn't exist, to create it.
The original post was: https://www.experts-exchange.com/questions/20405144/folder-browser-control.html
The code was:
Public Const BIF_RETURNONLYFSDIRS = &H1 'Only file system directories
Public Const BIF_DONTGOBELOWDOMAIN = &H2 'No network folders below domain level
Public Const BIF_STATUSTEXT = &H4 'Includes status area in the dialog (for callback)
Public Const BIF_RETURNFSANCESTORS = &H8 'Only returns file system ancestors
Public Const BIF_EDITBOX = &H10 'Allows user to rename selection
Public Const BIF_VALIDATE = &H20 'Insist on valid edit box result (or CANCEL)
Public Const BIF_USENEWUI = &H40 'Version 5.0. Use the new user-interface.
'Setting this flag provides the user with
'a larger dialog box that can be resized.
'It has several new capabilities including:
'dialog box, reordering, context menus, new
'folders, drag and drop capability within
'the delete, and other context menu commands.
'To use you must call OleInitialize or
'CoInitialize before calling SHBrowseForFolder.
Public Const BIF_BROWSEFORCOMPUTER = &H1000 'Only returns computers.
Public Const BIF_BROWSEFORPRINTER = &H2000 'Only returns printers.
Public Const BIF_BROWSEINCLUDEFILES = &H4000 'Browse for everything
Public Const WM_USER = &H400
Public Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100) 'BFFM_SETSTATUSTEXT
Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102) 'BFFM_SETSELECTION
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Public Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)
Public Const BFFM_INITIALIZED = 1
Public Const BFFM_SELCHANGED = 2
'public Const MAX_PATH = 260
Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)
Public Const BM_GETCHECK = &HF0
Public Const BM_GETSTATE = &HF2
Public Const BM_SETCHECK = &HF1
Public Const BM_SETSTATE = &HF3
Public Const BM_SETSTYLE = &HF4
Public Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Public Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Public Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Public Declare Function SHSimpleIDListFromPath Lib "shell32" Alias "#162" (ByVal szPath As String) As Long
Public Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Public m_CurrentDirectory As String
'!Is Directory Exist?
'<Note>: Requires Windows 2000 (or Windows NT 4.0 with Internet Explorer 4.0 or later);
' Requires Windows 98 (or Windows 95 with Internet Explorer 4.0 or later)
Public Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Public Function isDirExist(ByVal dir As String) As Boolean
isDirExist = CBool(PathFileExists(dir))
End Function
Public Function BrowseFolderByPath(ByRef frm As Form, Optional odtvTitle As String = "Select a directory", Optional sSelPath As String = "", Optional RootDirIsSelPath As Boolean = False, Optional ShowNewFolderButton As Boolean = False, Optional ShowStatusText As Boolean = False, Optional ShowTextBox As Boolean = False, Optional BrowseIncludeFiles As Boolean = False) As String
Dim BI As BrowseInfo
Dim pidl As Long
Dim lpSelPath As Long
Dim sPath As String * MAX_PATH
Dim mflags As Long
Dim RootDir As Long
m_CurrentDirectory = sSelPath & vbNullString
mflags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
'Display New Folder Button
If ShowNewFolderButton Then mflags = mflags + 64
'Display Status Text
If ShowStatusText Then mflags = mflags + BIF_STATUSTEXT + BIF_VALIDATE
'Display Text Box
If ShowTextBox Then mflags = mflags + 16
'Display Files
If BrowseIncludeFiles Then mflags = mflags + BIF_BROWSEINCLUDEFILES
If RootDirIsSelPath = True Then RootDir = GetPIDLFromPath(sSelPath)
With BI
.hwndOwner = frm.hwnd
.lpszTitle = odtvTitle
'.lpszTitle = lstrcat(odtvTitle, "")
.ulFlags = mflags
If isDirExist(sSelPath) = True Then
.pIDLRoot = RootDir
lpSelPath = LocalAlloc(LPTR, Len(sSelPath) + 1)
CopyMemory ByVal lpSelPath, ByVal sSelPath, Len(sSelPath) + 1
.lParam = lpSelPath
.lpfnCallback = FARPROC(AddressOf BrowseCallbackProcStr)
End If
End With
pidl = SHBrowseForFolder(BI)
If pidl Then
If SHGetPathFromIDList(pidl, sPath) Then
BrowseFolderByPath = Left$(sPath, InStr(sPath, vbNullChar) - 1)
End If
Call CoTaskMemFree(pidl)
End If
Call LocalFree(lpSelPath)
End Function
Public Function BrowseFolderByPIDL(ByRef frm As Form, Optional odtvTitle As String = "Select a directory", Optional sSelPath As String = "", Optional RootDirIsSelPath As Boolean = False, Optional ShowNewFolderButton As Boolean = False, Optional ShowStatusText As Boolean = False, Optional ShowTextBox As Boolean = False, Optional BrowseIncludeFiles As Boolean = False) As String
Dim BI As BrowseInfo
Dim pidl As Long
Dim lpSelPath As Long
Dim sPath As String * MAX_PATH
Dim mflags As Long
Dim RootDir As Long
mflags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
'Display New Folder Button
If ShowNewFolderButton Then mflags = mflags + 64
'Display Status Text
If ShowStatusText Then mflags = mflags + BIF_STATUSTEXT + BIF_VALIDATE
'Display Text Box
If ShowTextBox Then mflags = mflags + 16
'Display Files
If BrowseIncludeFiles Then mflags = mflags + BIF_BROWSEINCLUDEFILES
If RootDirIsSelPath = True Then RootDir = GetPIDLFromPath(sSelPath)
With BI
.hwndOwner = frm.hwnd
.lpszTitle = odtvTitle
.lpfnCallback = FARPROC(AddressOf BrowseCallbackProc)
.ulFlags = mflags
If isDirExist(sSelPath) = True Then
.pIDLRoot = RootDir
lpSelPath = GetPIDLFromPath(sSelPath)
CopyMemory ByVal lpSelPath, ByVal sSelPath, Len(sSelPath) + 1
.lParam = lpSelPath
.lpfnCallback = FARPROC(AddressOf BrowseCallbackProcStr)
End If
End With
pidl = SHBrowseForFolder(BI)
If pidl Then
If SHGetPathFromIDList(pidl, sPath) Then
BrowseFolderByPIDL = Left$(sPath, InStr(sPath, vbNullChar) - 1)
End If
'free the pidl returned by call to SHBrowseForFolder
Call CoTaskMemFree(pidl)
End If
'free the pidl set in call to GetPIDLFromPath
Call CoTaskMemFree(BI.lParam)
End Function
Public Function GetPIDLFromPath(sPath As String) As Long
'return the pidl to the path supplied by calling the
'undocumented API #162 (our name SHSimpleIDListFromPath).
'This function is necessary as, unlike documented APIs,
'the API is not implemented in 'A' or 'W' versions.
If IsWinNT Then
GetPIDLFromPath = SHSimpleIDListFromPath(Str Conv(sPath , vbUnicode))
Else
GetPIDLFromPath = SHSimpleIDListFromPath(sPa th)
End If
End Function
Public Function BrowseCallbackProc(ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
On Error Resume Next
Dim lpIDList As Long
Dim ret As Long
Dim sBuffer As String
'Callback for the Browse PIDL method.
'On initialization, set the dialog's
'pre-selected folder using the pidl
'set as the bi.lParam, and passed back
'to the callback as lpData param.
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hwnd, BFFM_SETSELECTIONA, _
False, ByVal lpData)
Case BFFM_SELCHANGED
'sBuffer = Space(MAX_PATH)
'
'ret = SHGetPathFromIDList(lParam , sBuffer)
'If ret = 1 Then
' Call SendMessage(hwnd, BFFM_SETSTATUSTEXTA, 0, sBuffer)
'End If
Case Else:
End Select
End Function
Public Function BrowseCallbackProcStr(ByVa l hwnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
On Error Resume Next
Dim lpIDList As Long
Dim ret As Long
Dim sBuffer As String
'Callback for the Browse STRING method.
'On initialization, set the dialog's
'pre-selected folder from the pointer
'to the path allocated as bi.lParam,
'passed back to the callback as lpData param.
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hwnd, BFFM_SETSELECTIONA, _
True, ByVal lpData)
Case BFFM_SELCHANGED
'sBuffer = Space(MAX_PATH)
'ret = SHGetPathFromIDList(lParam , sBuffer)
'If ret = 1 Then
' Call SendMessage(hwnd, BFFM_SETSTATUSTEXTA, 0, sBuffer)
'End If
Case Else:
End Select
End Function
Public Function FARPROC(pfn As Long) As Long
'A dummy procedure that receives and returns
'the value of the AddressOf operator.
'This workaround is needed as you can't assign
'AddressOf directly to a member of a user-
'defined type, but you can assign it to another
'long and use that (as returned here)
FARPROC = pfn
End Function
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Function IsWinNT() As Boolean
IsWinNT = CBool(Len(Environ$("OS")))
End Function
The original post was: https://www.experts-exchange.com/questions/20405144/folder-browser-control.html
The code was:
Public Const BIF_RETURNONLYFSDIRS = &H1 'Only file system directories
Public Const BIF_DONTGOBELOWDOMAIN = &H2 'No network folders below domain level
Public Const BIF_STATUSTEXT = &H4 'Includes status area in the dialog (for callback)
Public Const BIF_RETURNFSANCESTORS = &H8 'Only returns file system ancestors
Public Const BIF_EDITBOX = &H10 'Allows user to rename selection
Public Const BIF_VALIDATE = &H20 'Insist on valid edit box result (or CANCEL)
Public Const BIF_USENEWUI = &H40 'Version 5.0. Use the new user-interface.
'Setting this flag provides the user with
'a larger dialog box that can be resized.
'It has several new capabilities including:
'dialog box, reordering, context menus, new
'folders, drag and drop capability within
'the delete, and other context menu commands.
'To use you must call OleInitialize or
'CoInitialize before calling SHBrowseForFolder.
Public Const BIF_BROWSEFORCOMPUTER = &H1000 'Only returns computers.
Public Const BIF_BROWSEFORPRINTER = &H2000 'Only returns printers.
Public Const BIF_BROWSEINCLUDEFILES = &H4000 'Browse for everything
Public Const WM_USER = &H400
Public Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100) 'BFFM_SETSTATUSTEXT
Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102) 'BFFM_SETSELECTION
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Public Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)
Public Const BFFM_INITIALIZED = 1
Public Const BFFM_SELCHANGED = 2
'public Const MAX_PATH = 260
Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)
Public Const BM_GETCHECK = &HF0
Public Const BM_GETSTATE = &HF2
Public Const BM_SETCHECK = &HF1
Public Const BM_SETSTATE = &HF3
Public Const BM_SETSTYLE = &HF4
Public Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Public Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Public Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Public Declare Function SHSimpleIDListFromPath Lib "shell32" Alias "#162" (ByVal szPath As String) As Long
Public Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Public m_CurrentDirectory As String
'!Is Directory Exist?
'<Note>: Requires Windows 2000 (or Windows NT 4.0 with Internet Explorer 4.0 or later);
' Requires Windows 98 (or Windows 95 with Internet Explorer 4.0 or later)
Public Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Public Function isDirExist(ByVal dir As String) As Boolean
isDirExist = CBool(PathFileExists(dir))
End Function
Public Function BrowseFolderByPath(ByRef frm As Form, Optional odtvTitle As String = "Select a directory", Optional sSelPath As String = "", Optional RootDirIsSelPath As Boolean = False, Optional ShowNewFolderButton As Boolean = False, Optional ShowStatusText As Boolean = False, Optional ShowTextBox As Boolean = False, Optional BrowseIncludeFiles As Boolean = False) As String
Dim BI As BrowseInfo
Dim pidl As Long
Dim lpSelPath As Long
Dim sPath As String * MAX_PATH
Dim mflags As Long
Dim RootDir As Long
m_CurrentDirectory = sSelPath & vbNullString
mflags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
'Display New Folder Button
If ShowNewFolderButton Then mflags = mflags + 64
'Display Status Text
If ShowStatusText Then mflags = mflags + BIF_STATUSTEXT + BIF_VALIDATE
'Display Text Box
If ShowTextBox Then mflags = mflags + 16
'Display Files
If BrowseIncludeFiles Then mflags = mflags + BIF_BROWSEINCLUDEFILES
If RootDirIsSelPath = True Then RootDir = GetPIDLFromPath(sSelPath)
With BI
.hwndOwner = frm.hwnd
.lpszTitle = odtvTitle
'.lpszTitle = lstrcat(odtvTitle, "")
.ulFlags = mflags
If isDirExist(sSelPath) = True Then
.pIDLRoot = RootDir
lpSelPath = LocalAlloc(LPTR, Len(sSelPath) + 1)
CopyMemory ByVal lpSelPath, ByVal sSelPath, Len(sSelPath) + 1
.lParam = lpSelPath
.lpfnCallback = FARPROC(AddressOf BrowseCallbackProcStr)
End If
End With
pidl = SHBrowseForFolder(BI)
If pidl Then
If SHGetPathFromIDList(pidl, sPath) Then
BrowseFolderByPath = Left$(sPath, InStr(sPath, vbNullChar) - 1)
End If
Call CoTaskMemFree(pidl)
End If
Call LocalFree(lpSelPath)
End Function
Public Function BrowseFolderByPIDL(ByRef frm As Form, Optional odtvTitle As String = "Select a directory", Optional sSelPath As String = "", Optional RootDirIsSelPath As Boolean = False, Optional ShowNewFolderButton As Boolean = False, Optional ShowStatusText As Boolean = False, Optional ShowTextBox As Boolean = False, Optional BrowseIncludeFiles As Boolean = False) As String
Dim BI As BrowseInfo
Dim pidl As Long
Dim lpSelPath As Long
Dim sPath As String * MAX_PATH
Dim mflags As Long
Dim RootDir As Long
mflags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
'Display New Folder Button
If ShowNewFolderButton Then mflags = mflags + 64
'Display Status Text
If ShowStatusText Then mflags = mflags + BIF_STATUSTEXT + BIF_VALIDATE
'Display Text Box
If ShowTextBox Then mflags = mflags + 16
'Display Files
If BrowseIncludeFiles Then mflags = mflags + BIF_BROWSEINCLUDEFILES
If RootDirIsSelPath = True Then RootDir = GetPIDLFromPath(sSelPath)
With BI
.hwndOwner = frm.hwnd
.lpszTitle = odtvTitle
.lpfnCallback = FARPROC(AddressOf BrowseCallbackProc)
.ulFlags = mflags
If isDirExist(sSelPath) = True Then
.pIDLRoot = RootDir
lpSelPath = GetPIDLFromPath(sSelPath)
CopyMemory ByVal lpSelPath, ByVal sSelPath, Len(sSelPath) + 1
.lParam = lpSelPath
.lpfnCallback = FARPROC(AddressOf BrowseCallbackProcStr)
End If
End With
pidl = SHBrowseForFolder(BI)
If pidl Then
If SHGetPathFromIDList(pidl, sPath) Then
BrowseFolderByPIDL = Left$(sPath, InStr(sPath, vbNullChar) - 1)
End If
'free the pidl returned by call to SHBrowseForFolder
Call CoTaskMemFree(pidl)
End If
'free the pidl set in call to GetPIDLFromPath
Call CoTaskMemFree(BI.lParam)
End Function
Public Function GetPIDLFromPath(sPath As String) As Long
'return the pidl to the path supplied by calling the
'undocumented API #162 (our name SHSimpleIDListFromPath).
'This function is necessary as, unlike documented APIs,
'the API is not implemented in 'A' or 'W' versions.
If IsWinNT Then
GetPIDLFromPath = SHSimpleIDListFromPath(Str
Else
GetPIDLFromPath = SHSimpleIDListFromPath(sPa
End If
End Function
Public Function BrowseCallbackProc(ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
On Error Resume Next
Dim lpIDList As Long
Dim ret As Long
Dim sBuffer As String
'Callback for the Browse PIDL method.
'On initialization, set the dialog's
'pre-selected folder using the pidl
'set as the bi.lParam, and passed back
'to the callback as lpData param.
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hwnd, BFFM_SETSELECTIONA, _
False, ByVal lpData)
Case BFFM_SELCHANGED
'sBuffer = Space(MAX_PATH)
'
'ret = SHGetPathFromIDList(lParam
'If ret = 1 Then
' Call SendMessage(hwnd, BFFM_SETSTATUSTEXTA, 0, sBuffer)
'End If
Case Else:
End Select
End Function
Public Function BrowseCallbackProcStr(ByVa
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
On Error Resume Next
Dim lpIDList As Long
Dim ret As Long
Dim sBuffer As String
'Callback for the Browse STRING method.
'On initialization, set the dialog's
'pre-selected folder from the pointer
'to the path allocated as bi.lParam,
'passed back to the callback as lpData param.
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hwnd, BFFM_SETSELECTIONA, _
True, ByVal lpData)
Case BFFM_SELCHANGED
'sBuffer = Space(MAX_PATH)
'ret = SHGetPathFromIDList(lParam
'If ret = 1 Then
' Call SendMessage(hwnd, BFFM_SETSTATUSTEXTA, 0, sBuffer)
'End If
Case Else:
End Select
End Function
Public Function FARPROC(pfn As Long) As Long
'A dummy procedure that receives and returns
'the value of the AddressOf operator.
'This workaround is needed as you can't assign
'AddressOf directly to a member of a user-
'defined type, but you can assign it to another
'long and use that (as returned here)
FARPROC = pfn
End Function
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Function IsWinNT() As Boolean
IsWinNT = CBool(Len(Environ$("OS")))
End Function
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
For a start, the reason for the callback functions is so u can specify a starting directory
U also have two functions, one to browse by a path and one to browse by pidl (the id to a folder, one that changes over time anyway)
but for what u want, I dont think u need it that complicated, especially since u accepted what I posted :)
U also have two functions, one to browse by a path and one to browse by pidl (the id to a folder, one that changes over time anyway)
but for what u want, I dont think u need it that complicated, especially since u accepted what I posted :)
ASKER
Thanks for the clarification. Yes I have to say its best for me to KISS for now.
ASKER
Do you know what else the other, long winded, code does?