Link to home
Start Free TrialLog in
Avatar of Rob4077
Rob4077Flag for Australia

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(StrConv(sPath, vbUnicode))
  Else
    GetPIDLFromPath = SHSimpleIDListFromPath(sPath)
  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(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 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

ASKER CERTIFIED SOLUTION
Avatar of rockiroads
rockiroads
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Rob4077

ASKER

That did it. Thanks rockiroads.

Do you know what else the other, long winded, code does?
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 :)
Avatar of Rob4077

ASKER

Thanks for the clarification. Yes I have to say its best for me to KISS for now.