I'm using Application.FileDialog to let the user select a folder, as in:
Dim F As FileDialog
Set F = Application.FileDialog(msoFileDialogFolderPicker)
In this case the default folder contains no subfolders, so what the user sees is an empty box. Ideally, the dialog would not just list folders, but would list files disabled/grayed out so that the user would be able to see the contents of the folder he is picking.
Is there a way to do this on the cheap with a FileDialog or do I have to create my own form (ugh) ?
Here is something from my database. I have been using this for quite sometime now for VBA. This code is not mine and I found it long time ago on the web.
Sub Sample()
ret = BrowseForFolder("C:\")
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
BrowseForFolder = False
End Function
Related
I am new to VBA and obviously I am missing something. My code works for opening a word doc and sending data to it BUT does NOT for an ALREADY OPEN word doc. I keep searching for an answer on how to send info from Excel to an OPEN Word doc/Bookmark and nothing works.
I hope it is okay that I added all the code and the functions called. I really appreciate your help!
What I have so far
Sub ExcelNamesToWordBookmarks()
On Error GoTo ErrorHandler
Dim wrdApp As Object 'Word.Application
Dim wrdDoc As Object 'Word.Document
Dim xlName As Excel.Name
Dim ws As Worksheet
Dim str As String 'cell/name value
Dim cell As Range
Dim celldata As Variant 'added to use in the test
Dim theformat As Variant 'added
Dim BMRange As Object
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Set wb = ActiveWorkbook
strPath = wb.Path
If strPath = "" Then
MsgBox "Please save your Excel Spreadsheet & try again."
GoTo ErrorExit
End If
'GET FILE & path of Word Doc/Dot
strPathFile = strOpenFilePath 'call a function in MOD1
If strPathFile = "" Then
MsgBox "Please choose a Word Document (DOC*) or Template (DOT*) & try again." 'strPath = Application.TemplatesPath
GoTo ErrorExit
End If
If FileLocked(strPathFile) Then 'Err.Number = 70 if open
'read / write file in use 'do something
'NONE OF THESE WORK
Set wrdApp = GetObject(strPathFile, "Word.Application")
'Set wrdApp = Word.Documents("This is a test doc 2.docx")
'Set wrdApp = GetObject(strPathFile).Application
Else
'all ok 'Create a new Word Session
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
wrdApp.Activate 'bring word visiable so erros do not get hidden.
'Open document in word
Set wrdDoc = wrdApp.Documents.Open(Filename:=strPathFile) 'Open vs wrdApp.Documents.Add(strPathFile)<=>create new Document1 doc
End If
'Loop through names in the activeworkbook
For Each xlName In wb.Names
If Range(xlName).Cells.Count = 1 Then
celldata = Range(xlName.Value)
'do nothing
Else
For Each cell In Range(xlName)
If str = "" Then
str = cell.Value
Else
str = str & vbCrLf & cell.Value
End If
Next cell
'MsgBox str
celldata = str
End If
'Get format and strip away the spacing, negative color etc etc
'I know this is not right... it works but not best
theformat = Application.Range(xlName).DisplayFormat.NumberFormat
If Len(theformat) > 8 Then
theformat = Left(theformat, 5) 'was 8 but dont need cents
Else
'do nothing for now
End If
If wrdDoc.Bookmarks.Exists(xlName.Name) Then
'Copy the Bookmark's Range.
Set BMRange = wrdDoc.Bookmarks(xlName.Name).Range.Duplicate
BMRange.Text = Format(celldata, theformat)
'Re-insert the bookmark
wrdDoc.Bookmarks.Add xlName.Name, BMRange
End If
Next xlName
'Activate word and display document
With wrdApp
.Selection.Goto What:=1, Which:=2, Name:=1 'PageNumber
.Visible = True
.ActiveWindow.WindowState = wdWindowStateMaximize 'WAS 0 is this needed???
.Activate
End With
GoTo WeAreDone
'Release the Word object to save memory and exit macro
ErrorExit:
MsgBox "Thank you! Bye."
Set wrdDoc = Nothing
Set wrdApp = Nothing
Exit Sub
'Error Handling routine
ErrorHandler:
If Err Then
MsgBox "Error No: " & Err.Number & "; There is a problem"
If Not wrdApp Is Nothing Then
wrdApp.Quit False
End If
Resume ErrorExit
End If
WeAreDone:
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub
file picking:
Function strOpenFilePath() As String
Dim intChoice As Integer
Dim iFileSelect As FileDialog 'B
Set iFileSelect = Application.FileDialog(msoFileDialogOpen)
With iFileSelect
.AllowMultiSelect = False 'only allow the user to select one file
.Title = "Please... Select MS-WORD Doc*/Dot* Files"
.Filters.Clear
.Filters.Add "MS-WORD Doc*/Dot* Files", "*.do*"
.InitialView = msoFileDialogViewDetails
End With
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strOpenFilePath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
Else
'nothing yet
End If
End Function
checking if file is open...
Function FileLocked(strFileName As String) As Boolean
On Error Resume Next
' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open strFileName For Binary Access Read Write Lock Read Write As #1
Close #1
' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
' Display the error number and description.
MsgBox "Function FileLocked Error #" & str(Err.Number) & " - " & Err.Description
FileLocked = True
Err.Clear
End If
End Function
ANSWER BELOW. Backstory... So, after input from you guys and more research I discovered that I needed to set the active word document by using the file selection the user picked and that is then passed via late binding to the sub as an object to process. NOW it works if the word file is not in word OR if it is currently loaded into word AND not even the active document. The below code replaces the code in my original question.
Set Object app as word.
grab the file name.
Make the word doc selected active to manipulate.
Set the word object to the active doc.
THANK YOU EVERYONE!
If FileLocked(strPathFile) Then 'Err.Number = 70 if open
'read / write file in use 'do something
Set wrdApp = GetObject(, "Word.Application")
strPathFile = Right(strPathFile, Len(strPathFile) - InStrRev(strPathFile, "\"))
wrdApp.Documents(strPathFile).Activate ' need to set picked doc as active
Set wrdDoc = wrdApp.ActiveDocument ' works!
This should get you the object you need.
Dim WRDFile As Word.Application
Set WRDFile = GetObject(strPathFile)
'Have Microsoft Word 16.0 Object Library selected in your references
Dim wordapp As Object
Set wordapp = GetObject(, "Word.Application")
wordapp.Documents("documentname").Select
'works if you only have one open word document. In my case, I'm trying to push updates to word links from excel.
I have an excel file with part numbers listed in a column. On running, the code splits the first part number typed. From the first half the code finds the subfolder that contains that category of part numbers then the second half is the actual file name. Example 01T-1001-01. 01T is the subfolder name and the 1001-01 is the file name, it splits at -. However sometimes descriptions of the part are added in parenthesis so for example 1001-01 (Chuck). That is what the wild card is for.
The code is supposed to first check if AutoCAD is opened, if so then open the dwg in the opened AutoCAD application, if not then open a new application.
The issue is that it will open one drawing (first in the list) but will error out with "Run time error '438': Object doesn't support this property or method" It will not continue past Set ACADApp.ActiveDocument = ACADApp.Documents.Open(ACADPath) to open the other dwgs in the list
UPDATED Code below:
Dim ACADApp As AcadApplication
Dim ACADPath As String
Dim ACAD As Object
Dim NFile As Object
Sub Open_Dwg()
Dim Wildcard As String
Dim path As String
Dim target As String
Dim SplitString() As String
Dim i As Integer
Dim a As Integer
i = 1
If ACAD Is Nothing Then
Set ACAD = CreateObject("AutoCad.Application")
If ACAD Is Nothing Then
MsgBox "Could not start AutoCAD.", vbCritical
Exit Sub
End If
Else
Set ACAD = GetObject(, "AutoCAD.Application")
End If
Set ACADApp = ACAD
ACADApp.Visible = True
Do Until Cells(i, 1).Value = ""
ACADPath = ""
Wildcard = ""
OpenString = ""
path = "C:\Users\aholiday\Desktop\DEMO" 'Root Folder
target = Cells(i, 1).Value 'Get Targeted Cell Value
target = UCase(target) 'All Letters to Upper Case
SplitString() = Split(target, "-", 2) 'Split given name to obtain subfolder and name
path = path & "\" & SplitString(0) & "\" 'Build Complete Path
OpenString = path & SplitString(1) & ".dwg" 'File Path and Name
Wildcard = Dir(path & SplitString(1) & "*.dwg") 'File Path and Wildcard
If Dir(OpenString) <> "" Then
ACADPath = OpenString
OpenFile (ACADPath)
Else
If Wildcard <> "" Then 'If Not Then Use Wildcard
ACADPath = path & Wildcard
OpenFile (ACADPath)
Else
MsgBox ("File " & target & " Not Found")
End If
End If
i = i + 1
Loop
End Sub
Function OpenFile(ByVal ACADPath As String) As String
Set ACADApp.ActiveDocument = ACADApp.Documents.Open(ACADPath)
End Function
Here is a basic shell of what I use in our production application:
Sub Open_Dwg()
On Error Resume Next
Dim ACADApp As AcadApplication
Dim a As Object
Set a = GetObject(, "AutoCAD.Application")
If a Is Nothing Then
Set a = CreateObject("AutoCAD.Application")
If a Is Nothing Then
MsgBox "AutoCAD must be running before performing this action.", vbCritical
Exit Sub
End If
End If
Set ACADApp = a
ACADApp.Visible = True
Set ACADApp.ActiveDocument = ACADApp.Documents.Open("<your filename>")
End Sub
Note the modification of the GetObject call and how the document is being opened.
EDIT:
Using the above code as a starting point and applying it to the OP's code, you would end up with the following:
Option Explicit
Dim ACADApp As AcadApplication
Dim ACADPath As String
Dim ACAD As Object
Dim NFile As Object
Sub Open_Dwg()
Dim Wildcard As String
Dim OpenString As String
Dim path As String
Dim target As String
Dim SplitString() As String
Dim i As Integer
Dim a As Integer
'get or create an instance of autocad
On Error Resume Next
Set ACAD = Nothing
Set ACAD = GetObject(, "AutoCAD.Application")
If ACAD Is Nothing Then
Set ACAD = CreateObject("AutoCad.Application")
If ACAD Is Nothing Then
MsgBox "Could not start AutoCAD.", vbCritical
Exit Sub
End If
End If
Set ACADApp = ACAD
ACADApp.Visible = True
On Error GoTo 0
'process files
i = 1
Do Until Cells(i, 1).Value = ""
path = "C:\Users\aholiday\Desktop\DEMO" 'Root Folder
target = UCase(Cells(i, 1).Value) 'Get Targeted Cell Value
SplitString() = Split(target, "-", 2) 'Split given name to obtain subfolder and name
path = path & "\" & SplitString(0) & "\" 'Build Complete Path
OpenString = path & SplitString(1) & ".dwg" 'File Path and Name
Wildcard = Dir(path & SplitString(1) & "*.dwg") 'File Path and Wildcard
If Dir(OpenString) <> "" Then
OpenFile OpenString
Else
If Wildcard <> "" Then 'If Not Then Use Wildcard
OpenFile path & Wildcard
Else
MsgBox ("File " & target & " Not Found")
End If
End If
i = i + 1
Loop
End Sub
Function OpenFile(ByVal ACADPath As String) As String
ACADApp.Documents.Open ACADPath
End Function
I am using a VBA script where the first worksheets of all workbooks saved in a specific folder are consolidated in one workbook. What I want is, if any source workbook is open while running this script, then I should get a prompt that 'source workbook is open' and the script should not run.
VBA script of destination worksheet is as follows:
Private Sub CommandButton1_Click()
Dim directory As String, fileName As String, sheet As Worksheet, total As Integer
Dim WrdArray() As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = "C:\test\"
fileName = Dir(directory & "*.xl??")
Application.EnableEvents = False
Do While fileName <> ""
Workbooks.Open (directory & fileName)
WrdArray() = Split(fileName, ".")
For Each sheet In Workbooks(fileName).Worksheets
Workbooks(fileName).ActiveSheet.Name = WrdArray(0)
total = Workbooks("import-sheets.xlsm").Worksheets.Count
Workbooks(fileName).Worksheets(sheet.Name).Copy After:=Workbooks("import-sheets.xlsm").Worksheets(total)
GoTo exitFor:
Next sheet
exitFor:
Workbooks(fileName).Close
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I appreciate your help in advance
Untested but it should work, source:
https://support.microsoft.com/en-us/kb/291295
Function IsFileOpen(filename As String)
Dim filenum As Integer, errnum As Integer
On Error Resume Next ' Turn error checking off.
filenum = FreeFile() ' Get a free file number.
' Attempt to open the file and lock it.
Open filename For Input Lock Read As #filenum
Close filenum ' Close the file.
errnum = Err ' Save the error number that occurred.
On Error GoTo 0 ' Turn error checking back on.
' Check to see which error occurred.
Select Case errnum
' No error occurred.
' File is NOT already open by another user.
Case 0
IsFileOpen = False
' Error number for "Permission Denied."
' File is already opened by another user.
Case 70
IsFileOpen = True
' Another error occurred.
Case Else
Error errnum
End Select
End Function
if you want to check if a workbook (an Excel file) is opened, try this function.
Public Function isWbOpened(ByVal wb As String) As Boolean
Dim workB As Workbook
isWbOpened = False
For Each workB In Workbooks
If workB.FullName = wb Or workB.Name = wb Then ''FullName : path + filename Name : filename only
isWbOpened = True
End If
Next workB
End Function
if the function return TRUE, then the Excel file is open, so skeep your script.
example:
if isWbOpened("theExcelFile.xlsx") then
msgbox "theExcelFile.xlsx is open"
end if
You can enumerate the files in a folder then test them to see if any is open before proceeding. Please note - the following code is assuming you are the one with them open, so if a shared file is open this may have to be adapted
Sub TestFolder()
Debug.Print XLFileIsOpen("C:\Test")
End Sub
Function XLFileIsOpen(sFolder As String) As Boolean
For Each Item In EnumerateFiles(sFolder)
If IsWorkBookOpen(CStr(Item)) = True Then XLFileIsOpen = True
Next Item
End Function
Function EnumerateFiles(sFolder As String) As Variant
Dim objFSO As Object: Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objFolder As Object: Set objFolder = objFSO.GetFolder(sFolder)
Dim objFile As Object, V() As String
For Each objFile In objFolder.Files
If IsArrayAllocated(V) = False Then
ReDim V(0)
Else
ReDim Preserve V(UBound(V) + 1)
End If
V(UBound(V)) = objFile.Name
Next objFile
EnumerateFiles = V
End Function
Function IsArrayAllocated(Arr As Variant) As Boolean
On Error Resume Next
IsArrayAllocated = IsArray(Arr) And Not IsError(LBound(Arr, 1)) And LBound(Arr, 1) <= UBound(Arr, 1)
End Function
Function IsWorkBookOpen(sFile As String) As Boolean
On Error Resume Next
IsWorkBookOpen = Len(Application.Workbooks(sFile).Name) > 0
End Function
I am trying to do the following:
find folder based on the path given by a cell value
determine whether it's subfolders are empty
if the subfolders are all empty - put "subfolders empty" in a cell
if there are some files within any of the subfolders
put "contains files in a cell"
My code runs but it is skipping over the subfolders sub procedure.
Sub search_subfolders()
Application.ScreenUpdating = False
On Error Resume Next
With Workbooks("Folder_creator.xlsm").Sheets("Sheet1")
Dim Rng As Range
Dim Pth As String
Dim Model As String
Dim x As String
Set Rng = .Range("a2:a527")
Pth = .Range("b2").Value
For r = 2 To 527
Model = .Cells(r, 1).Text
ModelPth = Pth & Model & "\"
Set FSO = CreateObject("Scripting.FileSystemObject")
ShowSubFolders FSO.ModelPth
.Cells(r, 4).Value = x
Next r
End With
Application.ScreenUpdating = True
End Sub
Sub ShowSubFolders(ModelPth)
For Each Subfolder In ModelPath.SubFolders
If Subfolder.Size = 0 Then
x = "Subfolders empty"
Else
x = "Contains files"
End If
ShowSubFolders Subfolder
Next
End Sub
I think this is something to do with trying to pass variables to it without the correct syntax.
Ok, there are a number of problems with your code. Please see the code below for something that should work. I tried to explain changes with comments. Feel free to comment on this post if you need me to elaborate. Good luck, hope this helps.
Also, I wasn't sure if you wanted to check your ModelPth folder or subfolders in your ModelPth folder, so I made subroutines for both. I also took the liberty of implementing some small scale error handling.
'x needs to be declared here if it is to be accessed by multiple subroutines
Private x As String
Sub search_subfolders()
Application.ScreenUpdating = False
'Removed "On Error Resume next" .... this should only be used very sparingly
'Slightly better is to only use on a short section followed by "On Error Goto 0"
'or use "On Error Goto xyz" where "xyz" is a label
Dim sheet As Worksheet
'Perhaps you do want to refer to a workbook other than the one calling this macro
'but my guess is that this is intended to run within the workbook calling in
'in which case, it's much better to use "Activeworkbook" than to rely on a name that may change
'You may want to also reconsider your use of "Sheet1", you can use Sheets(1) which has it's own problems, or use "ActiveSheet",
'or just use "Range("B2")" which, is the same as ActiveWorkbook.ActiveSheet.Range("B2")
Set sheet = ActiveWorkbook.Sheets("Sheet1")
'If code is housed under a sheet module instead of in a standard module,
'your best option is to use "Set sheet = Me" and workbook shouldn't need to be specified.
'If you do ever want to specify calling workbook, you can use "ThisWorkbook"
Dim Rng As Range
Set Rng = sheet.Range("A2:A527")
Dim Pth As String
Pth = sheet.Range("b2").Value
Dim Model As String
'It's really best to avoid using "with" statements... just declare a variable and run with that
'In this case just make a sheet variable
For r = 2 To 527
Model = sheet.Cells(r, 1).Text
ModelPth = Pth & Model & "\"
'Are you sure ModelPth is in the correct syntax?
'That is, youmay want (Pth & "\" & Model & "\") instead.
CheckSubFolderContent ModelPth
sheet.Cells(r, 4).Value = x
CheckFolderContent ModelPth
sheet.Cells(r, 5).Value = x
Next r
End Sub
Sub CheckSubFolderContent(ModelPth)
'Checks for content in subfolders in a folder specified by path
x = "No Subfolders found"
'Error handling for Model = ""
If Right(ModelPth, 2) = "\\" Then
x = "N/A"
Exit Sub
End If
Dim FSO, Parent As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set Parent = FSO.GetFolder(ModelPth)
If Err > 0 Then
x = "Error! Parent folder does not exist."
Exit Sub
End If
For Each Subfolder In Parent.SubFolders
If Subfolder.Size = 0 Then
x = "Folder has subfolders without content"
Else
x = "Folder has subfolders with content"
End If
'Why this recursive line? "ShowSubFolders Subfolder"
'Recursive calls should be avoided and are rarely necesary.
Next
If Err > 0 Then x = "Error!"
On Error GoTo 0
End Sub
Sub CheckFolderContent(ModelPth)
'Checks for content in a folder specified by path
x = "No Subfolders found"
If Right(ModelPth, 2) = "\\" Then
x = "N/A"
Exit Sub
End If
Dim FSO, Folder As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set Folder = FSO.GetFolder(ModelPth)
If Err > 0 Then
x = "Error! Parent folder does not exist."
Exit Sub
End If
If Folder.Size = 0 Then
x = "Folder is empty"
Else
x = "Folder has content"
End If
If Err > 0 Then x = "Error!"
On Error GoTo 0
End Sub
Couple of things you are doing wrong.
1. You are trying to access sub-folders without making FSO(FileSystemObject) accessible in ShowSubFolders sub.
2. x is not global variable and yet you are trying to access it.
3. Less conditions in ShowSubFolders sub.
Here is the updated code.
Dim FSO As Object '<-- This one sets FSO global
Dim x As String '<-- This one sets x global
Sub search_subfolders()
Application.ScreenUpdating = False
On Error Resume Next
Workbooks("Folder_creator.xlsm").Sheets("Sheet1")
Dim Rng As Range
Dim Pth As String
Dim Model As String
Set Rng = .Range("a2:a527")
Pth = .Range("b2").Value
For r = 2 To 527
Model = .Cells(r, 1).Text
ModelPth = Pth & Model & "\"
Set FSO = CreateObject("Scripting.FileSystemObject")
ShowSubFolders FSO.GetFolder(ModelPth)
.Cells(r, 4).Value = x
x = ""
Next r
End With
Application.ScreenUpdating = True
End Sub
Sub ShowSubFolders(Folder)
Dim SubFolder
If Folder.SubFolders.Count > 0 Then
For Each SubFolder In Folder.SubFolders
ShowSubFolders SubFolder
If SubFolder.Size = 0 Then
x = "Subfolders empty"
Else
x = "Contains files"
End If
Next
Else
x = "Subfolders empty"
End If
End Sub
I'm having an issue that when I try to use multiple instances of file dialogs the information from the first is always overwritten by the selection in the second dialog.
What i need to do is:
Select a template file
Select a destination folder
Save the template file as a .docm file.
What happens is that the second time application.FileDialog is used all the information in fd is lost and is overwritten by the entries into fldr.
Can there only be one dialog object per macro?
Dim fd As FileDialog
Dim FileChosen As Integer
Dim FileName As String
Dim fldr As FileDialog
Dim fldrSelect As String
Dim i As Integer
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'use the standard title and filters, but change the
'initial folder
fd.InitialFileName = "H:\UpdatedSalesTemplates\"
fd.InitialView = msoFileDialogViewList
'allow multiple file selection
fd.AllowMultiSelect = True
FileChosen = fd.Show
If FileChosen = -1 Then
'Select the directory using a file dialog
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
fldr.InitialView = msoFileDialogViewList
fldr.Title = "Select Destination"
fldr.AllowMultiSelect = False
fldrSelected = fldr.Show
'
Microsoft says that there may be only one: "...Each host application can only create a single instance of the FileDialog object...".
In any case, this shouldn't represent a serious problem as far as you can store all the relevant information (selected path, initial directory, etc.) in (string) variables.
For such scenarios where you need a file/folder picker in one macro/procedure/userform, I use a custom made userform. See if you like it. Place commandbuttons and textboxes as shown below
Screenshot
Code
Note: Both the textboxes .Locked property was set to True in design time so that the user cannot modify the textboxes manually.
Option Explicit
Dim Ret
'~~> Browse File
Private Sub CommandButton1_Click()
Ret = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx")
If Ret <> False Then TextBox1.Text = Ret
End Sub
'~~> Browse Folder
Private Sub CommandButton2_Click()
Ret = BrowseForFolder("C:\")
If Ret <> False Then TextBox2.Text = Ret
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'~~> If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function