Need to edge out the competition for your dream job? Train for certifications today.
Experts Exchange Solution brought to you by
"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.
Are you thinking about creating an Amazon Web Services account for your business? Not sure where to start? In this course you’ll get an overview of the history of AWS and take a tour of their user interface.
' Browse for a Folder using SHBrowseForFolder API function with a callback
' function BrowseCallbackProc.
' This Extends the functionality that was given in the
' MSDN Knowledge Base article Q179497 "HOWTO: Select a Directory
' Without the Common Dialog Control".
' After reading the MSDN knowledge base article Q179378 "HOWTO: Browse for
' Folders from the Current Directory", I was able to figure out how to add
' a callback function that sets the starting directory and displays the
' currently selected path in the "Browse For Folder" dialog.
' I used VB 6.0 (SP3) to compile this code. Should work in VB 5.0.
' However, because it uses the AddressOf operator this code will not
' work with versions below 5.0.
' This code works in Window 95a so I assume it will work with later versions.
' Stephen Fonnesbeck
' Feb 20, 2000
' Dim folder As String
' folder = BrowseForFolder(Me, "Select A Directory", "C:\startdir\anywhere")
' If Len(folder) = 0 Then Exit Sub 'User Selected Cancel
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
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
Private m_CurrentDirectory As String 'The current directory
Public Function BrowseForFolder(Optional Title As String = "Select a directory", Optional StartDir As String = "", Optional ShowNewFolderButton As Boolean = False, Optional ShowStatusText As Boolean = False, Optional ShowTextBox As Boolean = False, Optional BrowseIncludeFiles As Boolean = False) 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
Dim mflags As Long
m_CurrentDirectory = StartDir & vbNullChar
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
If BrowseIncludeFiles Then mflags = mflags + BIF_BROWSEINCLUDEFILES
szTitle = Title
.hWndOwner = 0
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = mflags 'BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT
.lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc) 'get address of function.
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
BrowseForFolder = sBuffer
BrowseForFolder = ""
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
Call SendMessage(hWnd, BFFM_SETSELECTION, 1, m_CurrentDirectory)
sBuffer = Space(MAX_PATH)
ret = SHGetPathFromIDList(lp, sBuffer)
If ret = 1 Then
Call SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
BrowseCallbackProc = 0
' This function allows you to assign a function pointer to a vaiable.
Private Function GetAddressofFunction(add As Long) As Long
GetAddressofFunction = add
Dim Path As String
Dim fileName As String
Path = BrowseForFolder()
If Path = "" Then Exit Sub
'Path = IIf(Right(Cells(8, 3), 1) <> "\", Cells(8, 3) & "\", Cells(8, 3))
Path = IIf(Right(Path, 1) <> "\", Path & "\", Path)
'try customize this accordingly
fileName = "Industry_DB" & Format(Now(), "YYYYMMDD HHMMSS") & ".xls"
ActiveWorkbook.SaveAs Path & fileName, xlExcel8
MsgBox Path & fileName & " saved successfully.", vbInformation, "Completed"
'Dim wb As Workbook
'For Each wb In Workbooks
Open in new window
Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.
Answer to Question 1: YES, I'm looking for a way to direct the save to a specific user chosen location (the Save As was a nice extra I hadn't thought of.... I'm going to also need to retrieve the file and import it later....so it might be good to simply save it with one particular name that the User cannot change).
From novice to tech pro — start learning today.
Premium members can enroll in this course at no extra cost.
Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.
Have a better answer? Share it in a comment.
Please enter a first name
Please enter a last name
Must be at least 4 characters long.
Join and Comment