Solved

VBA - Adding default location to Folder Path dialog box

Posted on 2010-09-07
14
756 Views
Last Modified: 2012-05-10
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
Comment
Question by:NerishaB
  • 6
  • 4
  • 4
14 Comments
 
LVL 47

Expert Comment

by:Wayne Taylor (webtubbs)
ID: 33616480
You simply need to modify the 4th parameter of the BrowseForFolder function...

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

Wayne
0
 

Author Comment

by:NerishaB
ID: 33616524
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
 
LVL 85

Expert Comment

by:Rory Archibald
ID: 33616632
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
Networking for the Cloud Era

Join Microsoft and Riverbed for a discussion and demonstration of enhancements to SteelConnect:
-One-click orchestration and cloud connectivity in Azure environments
-Tight integration of SD-WAN and WAN optimization capabilities
-Scalability and resiliency equal to a data center

 
LVL 47

Accepted Solution

by:
Wayne Taylor (webtubbs) earned 500 total points
ID: 33616636
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
 
LVL 47

Expert Comment

by:Wayne Taylor (webtubbs)
ID: 33616647
I did not know Excel had a Folder Picker available. Live and learn....
0
 

Author Comment

by:NerishaB
ID: 33616742
@ wetubbs:

Where would I put that code??
0
 

Author Closing Comment

by:NerishaB
ID: 33616829
Thanks, I put it at the top of my code.  Works brilliantly.
0
 
LVL 47

Expert Comment

by:Wayne Taylor (webtubbs)
ID: 33617011
NerishaB,

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

Wayne
0
 
LVL 85

Expert Comment

by:Rory Archibald
ID: 33617031
93 lines of code looks more impressive than 8. ;)
0
 

Author Comment

by:NerishaB
ID: 33617048
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
 
LVL 85

Expert Comment

by:Rory Archibald
ID: 33617066
No problem - the only important thing is that you have a solution! :)
0
 

Author Comment

by:NerishaB
ID: 33626935
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
 
LVL 85

Expert Comment

by:Rory Archibald
ID: 33626953
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
 

Author Comment

by:NerishaB
ID: 33626994
Thanks, got it now.
0

Featured Post

Free Tool: Postgres Monitoring System

A PHP and Perl based system to collect and display usage statistics from PostgreSQL databases.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction This Article is a follow-up to my Mappit! Addin Article (http://www.experts-exchange.com/A_2613.html), it was inspired by an email posting I made to EUSPRIG (http://www.eusprig.org/index.htm), I will briefly cover: 1) An overvie…
When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa‚Ķ

839 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