Solved

Allow creation and/or selection of folder

Posted on 2006-11-19
4
679 Views
Last Modified: 2008-01-09
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: http://www.experts-exchange.com/Databases/MS_Access/Q_20405144.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

0
Comment
Question by:Rob4077
  • 2
  • 2
4 Comments
 
LVL 65

Accepted Solution

by:
rockiroads earned 500 total points
ID: 17978904
Looks a bit long winded your code. I have used this api call before - in fact its even one Ive given as solution a number of times.

Am I right in thinking that all u want do to is to show a select folder dialog with the option of creating new directories?

how about this then - dump into a module somewhere


Private Type BROWSEINFO
    hOwner          As Long         'handle to window opening dialog
    pidlRoot        As Long         'A pointer to an ITEMIDLIST structure (a.k.a. a PIDL) which identifies the root folder for the dialog box. The user's selection is limited to this folder and any subfolders under it
    pszDisplayName  As String       'Receives the null-terminated display name of the folder the user selects. This must be initialized to an empty string of at least 260 characters
    lpszTitle       As String       'The title of the dialog box, which will appear above the folder tree
    ulFlags         As Long         'See BIF flags above
    lpfn            As Long         'A pointer to the BrowseCallbackProc callback function used to process the dialog box's messages. To use the default behavior, set this to 0
    lParam          As Long         'An application-defined value to pass to the callback function, if needed
    iImage          As Long         'Receives the index of the system image associated with the user's selection
End Type

Private Declare Function SHBrowseForFolder Lib "shell32" 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 Const BIF_USENEWUI = &H40


Public Function BrowseDirectory() As String

    Dim tBI As BROWSEINFO
    Dim pIdl As Long
    Dim sPath As String
   
   
    tBI.lpszTitle = "Browse Directory And Allow User To Create Test"
    tBI.ulFlags = BIF_USENEWUI
    pIdl = SHBrowseForFolder(tBI)
   
    'Check for cancel
    If pIdl = 0 Then Exit Function

    'Get selected path from the id list, will rtn False if the id list can't be converted
    sPath = String$(260, 0)
    SHGetPathFromIDList ByVal pIdl, ByVal sPath
   
    ' Display the path and the name of the selected folder
    BrowseDirectory = Left(sPath, InStr(sPath, vbNullChar) - 1)
   
    MsgBox BrowseDirectory
End Function





Now just call the function

BrowseDirectory

it returns the name of the folder selected
0
 

Author Comment

by:Rob4077
ID: 17979246
That did it. Thanks rockiroads.

Do you know what else the other, long winded, code does?
0
 
LVL 65

Expert Comment

by:rockiroads
ID: 17979300
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 :)
0
 

Author Comment

by:Rob4077
ID: 17979387
Thanks for the clarification. Yes I have to say its best for me to KISS for now.
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Most if not all databases provide tools to filter data; even simple mail-merge programs might offer basic filtering capabilities. This is so important that, although Access has many built-in features to help the user in this task, developers often n…
When you are entering numbers in a speadsheet, and don't remember what 6×7 is, you just type “=6*7" instead. It works in every cell! This is not so in Access. To enter the elusive 42 in a text box, you have to find a calculator, and then copy the re…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
In Microsoft Access, learn different ways of passing a string value within a string argument. Also learn what a “Type Mis-match” error is about.

758 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now