• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 819
  • Last Modified:

VBA - Adding default location to Folder Path dialog box

Hi,

I have code to open up a specfic location on the users computer to save their files.  This opens up with the default directoer being C:\.  Is there any way that I can set it such that it defaults to C:\Main\ExcelDoc\, yest still have the ability to change it, if this is not where they want to save it?  See my code below.
Function GetFolderPath() As String
    Dim oShell As Object
    Set oShell = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please select folder", 0, "c:\\")
    If Not oShell Is Nothing Then
        GetFolderPath = oShell.Items.Item.Path
    Else
        GetFolderPath = vbNullString
    End If
    Set oShell = Nothing
End Function

Open in new window

0
NerishaB
Asked:
NerishaB
  • 6
  • 4
  • 4
1 Solution
 
Wayne Taylor (webtubbs)Commented:
You simply need to modify the 4th parameter of the BrowseForFolder function...

    BrowseForFolder(0, "Please select folder", 0, "C:\Main\ExcelDoc\")

Wayne
0
 
NerishaBAuthor Commented:
I have tried that.  But I want it to default to that, but there is no option for the user to go back up to search for another folder.  For instance, if the user wants to save it to the desktop.  
0
 
Rory ArchibaldCommented:
For example:



Function GetFolder() As String
    Dim dlg As FileDialog
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    dlg.InitialFileName = "C:\Main\ExcelDoc\"
    If dlg.Show = -1 Then
        GetFolder = dlg.SelectedItems(1)
    End If
End Function

Open in new window

0
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
Wayne Taylor (webtubbs)Commented:
That's true. The 4th parameter specifies the root directory, meaning the user cannot select a folder higher than that.

Take a look at this question, which shows how you can get around this....

http://www.experts-exchange.com/Programming/Languages/Visual_Basic/Q_21716577.html

The below code is a modification of the above, which doesn't not use a Form. Sample usage would be like this....

    getdir = BrowseForFolder(Application.hwnd, "Select A Directory", "C:\Main\ExcelDoc\")
    If Len(getdir) = 0 Then Exit Sub  'user selected cancel
    MsgBox getdir

Wayne
Option Explicit

Private Const BIF_STATUSTEXT = &H4&
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260

Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long

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

Private m_CurrentDirectory As String   'The current directory
'

Public Function BrowseForFolder(hwnd, Title As String, StartDir As String) As String
  'Opens a Treeview control that displays the directories in a computer

  Dim lpIDList As Long
  Dim szTitle As String
  Dim sBuffer As String
  Dim tBrowseInfo As BrowseInfo
  m_CurrentDirectory = StartDir & vbNullChar

  szTitle = Title
  With tBrowseInfo
    .hWndOwner = hwnd
    .lpszTitle = lstrcat(szTitle, "")
    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT
    .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)  'get address of function.
  End With

  lpIDList = SHBrowseForFolder(tBrowseInfo)
  If (lpIDList) Then
    sBuffer = Space(MAX_PATH)
    SHGetPathFromIDList lpIDList, sBuffer
    sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
    BrowseForFolder = sBuffer
  Else
    BrowseForFolder = ""
  End If
 
End Function
 
Private Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
 
  Dim lpIDList As Long
  Dim ret As Long
  Dim sBuffer As String
 
  On Error Resume Next  'Sugested by MS to prevent an error from
                        'propagating back into the calling process.
     
  Select Case uMsg
 
    Case BFFM_INITIALIZED
      Call SendMessage(hwnd, BFFM_SETSELECTION, 1, m_CurrentDirectory)
     
    Case BFFM_SELCHANGED
      sBuffer = Space(MAX_PATH)
     
      ret = SHGetPathFromIDList(lp, sBuffer)
      If ret = 1 Then
        Call SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
      End If
     
  End Select
 
  BrowseCallbackProc = 0
 
End Function

' This function allows you to assign a function pointer to a vaiable.
Private Function GetAddressofFunction(add As Long) As Long
  GetAddressofFunction = add
End Function

Open in new window

0
 
Wayne Taylor (webtubbs)Commented:
I did not know Excel had a Folder Picker available. Live and learn....
0
 
NerishaBAuthor Commented:
@ wetubbs:

Where would I put that code??
0
 
NerishaBAuthor Commented:
Thanks, I put it at the top of my code.  Works brilliantly.
0
 
Wayne Taylor (webtubbs)Commented:
NerishaB,

Thank you for the accept, but I do have to ask, did you see Rory's code at http:#a33616632 ?

Wayne
0
 
Rory ArchibaldCommented:
93 lines of code looks more impressive than 8. ;)
0
 
NerishaBAuthor Commented:
Yes wetubbs, I did look at rorya's code.  It does work, but I am creating this for a client that is very difficult.  He did not like the fact that I changed the way the initial browse for folder screen.  Sorry rorya.  Yours did work though. :-)
0
 
Rory ArchibaldCommented:
No problem - the only important thing is that you have a solution! :)
0
 
NerishaBAuthor Commented:
Actually, wetubbs, with your code in place, I just tested it now and found out that even though I set it to save to a default location, it always saves my files to the c: Drive.  See my code below:

I call it with the following function:
Function GetFolderPath() As String
   Dim getdir As String
     getdir = BrowseForFolder(Application.hwnd, "Select a Directory", "C:\Netserver\oztech_dev_oz\oz_excel\")
     If Len(getdir) = 0 Then
       Exit Function
    MsgBox getdir
    End If
     
End Function
Option Explicit
Public FromProj As VBIDE.VBProject, ToProj As VBIDE.VBProject
Public ImpExp As Integer
Public WName As String
Public ExpName As String

Private Const BIF_STATUSTEXT = &H4&
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260

Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long

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

Private m_CurrentDirectory As String   'The current directory
'

Public Function BrowseForFolder(hwnd, Title As String, StartDir As String) As String
  'Opens a Treeview control that displays the directories in a computer

  Dim lpIDList As Long
  Dim szTitle As String
  Dim sBuffer As String
  Dim tBrowseInfo As BrowseInfo
  m_CurrentDirectory = StartDir & vbNullChar

  szTitle = Title
  With tBrowseInfo
    .hWndOwner = hwnd
    .lpszTitle = lstrcat(szTitle, "")
    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT
    .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)  'get address of function.
  End With

  lpIDList = SHBrowseForFolder(tBrowseInfo)
  If (lpIDList) Then
    sBuffer = Space(MAX_PATH)
    SHGetPathFromIDList lpIDList, sBuffer
    sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
    BrowseForFolder = sBuffer
  Else
    BrowseForFolder = ""
  End If
 
End Function
 
Private Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
 
  Dim lpIDList As Long
  Dim ret As Long
  Dim sBuffer As String
 
  On Error Resume Next  'Sugested by MS to prevent an error from
                        'propagating back into the calling process.
     
  Select Case uMsg
 
    Case BFFM_INITIALIZED
      Call SendMessage(hwnd, BFFM_SETSELECTION, 1, m_CurrentDirectory)
     
    Case BFFM_SELCHANGED
      sBuffer = Space(MAX_PATH)
     
      ret = SHGetPathFromIDList(lp, sBuffer)
      If ret = 1 Then
        Call SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
      End If
     
  End Select
 
  BrowseCallbackProc = 0
 
End Function

' This function allows you to assign a function pointer to a vaiable.
Private Function GetAddressofFunction(add As Long) As Long
  GetAddressofFunction = add
End Function

Open in new window

0
 
Rory ArchibaldCommented:
You don't actually return the folder:



Function GetFolderPath() As String
   Dim getdir As String
     getdir = BrowseForFolder(Application.hwnd, "Select a Directory", "C:\Netserver\oztech_dev_oz\oz_excel\")
     If Len(getdir) = 0 Then
       Exit Function

    End If
    GetFolderPath = getdir
End Function

Open in new window

0
 
NerishaBAuthor Commented:
Thanks, got it now.
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 6
  • 4
  • 4
Tackle projects and never again get stuck behind a technical roadblock.
Join Now