asked on

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

Wayne Taylor (webtubbs)

You simply need to modify the 4th parameter of the BrowseForFolder function...

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

Wayne

NerishaB

ASKER

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.

Rory Archibald

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

ASKER CERTIFIED SOLUTION

Wayne Taylor (webtubbs)

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Wayne Taylor (webtubbs)

I did not know Excel had a Folder Picker available. Live and learn....

NerishaB

ASKER

@ wetubbs:

Where would I put that code??

NerishaB

ASKER

Thanks, I put it at the top of my code. Works brilliantly.

Wayne Taylor (webtubbs)

NerishaB,

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

Wayne

Rory Archibald

93 lines of code looks more impressive than 8. ;)

NerishaB

ASKER

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. :-)

Rory Archibald

No problem - the only important thing is that you have a solution! :)

NerishaB

ASKER

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

Rory Archibald

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

NerishaB

ASKER

Thanks, got it now.