I have a dialog box to pick a folder name and display the name of the folder that the user selects.
If the user selects cancel instead of folder path and OK, it throws an error.
I used a status variable and noticed that upon cancel the status changes to -1. So I tried to implement the code that is in comment section using a if condition to exit the sub.
That doesn't work in the case of selecting a folder when the commented part is present in the code.
Without that it works in selecting a folder.
sub abc()
Set diaFolder = Application.FileDialog(msoFileDialogFolderPicker)
diaFolder.AllowMultiSelect = False
diaFolder.Title = "Select a folder then hit OK"
diaFolder.Show
'Status = diaFolder.Show
'If Status < 0 Then
'Exit Sub
'End If
a = diaFolder.SelectedItems(1)
MsgBox ("Folder selected is :" & a)
ens sub
Keep in mind that vbFalse = 0 and vbTrue = -1.
In other words clicking 'OK' would return -1 and clicking 'Cancel' would return 0.
Try the following code:
Sub abc()
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select a folder then hit OK"
If .Show = -1 Then
MsgBox ("Folder selected is :" & .SelectedItems(1))
Else
Exit Sub
End If
End With
End Sub
Sub abc()
Set diaFolder = Application.FileDialog(msoFileDialogFolderPicker)
diaFolder.AllowMultiSelect = False
diaFolder.Title = "Select a folder then hit OK"
Dim status As Integer
status = diaFolder.Show
If status <> -1 Then
MsgBox "Cancel Chosen"
Exit Sub
End If
a = diaFolder.SelectedItems(1)
MsgBox ("Folder selected is :" & a)
End Sub
I know this is closed out but wanted to try posting for the first time. =D
If there are no items selected, *SelectedItems(1)*doesn't exist, and Excel will return an error. That's what's happening when the user presses the Cancel button.
A solution for this is to check how many items are selected using the structure below:
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
'Optional: limits the user to choosing a single option. Necessary if you want to avoid an error because the user selected multiple files.
.Title = "Dialog Title" 'Changing the title is also Optional
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Canceled by user" 'or just do nothing!
Else
MyVar = .SelectedItems(1)
End If
'Alternatively, "if .selecteditems.count = 1 then myvar = .selecteditems(1)" can be used
End With
Related
I have a code that would help me with printing a document from Excel.
It has a couple dialogue questions for adding serial number sequence and number of copies.
Unfortunately, it doesn't open the Print dialogue, where I can select a printer and it's preferences.
The code would just immediately print to my default printer.
I need to add some custom features like 2-side printing and stapling in the top left corner.
For that purpose I want to use .Sendkeys
I tried adding the string Application.SendKeys "%fpr" (my printer preferences dialogue) here and there inside the code to no avail.
Please help inserting the sting.
Alternatively - maybe there is a command for .PrintOut that I could add for 2-side printing and a staple finish?
Private Sub CommandButton1_Click()
Dim xCount As Variant
Dim xJAC As Variant
Dim xID As Variant
Dim xScreen As Boolean
Dim I As Long
On Error Resume Next
Application.SendKeys "%fpr"
LInput:
xJAC = Application.InputBox("Please enter the job number (Leave Out JAC):", "")
xCount = Application.InputBox("Please enter the number of copies you want to print:", "")
xID = Application.InputBox("Please enter the Starting ID of the product:", "")
If TypeName(xJAC) = "Boolean" Then Exit Sub
If TypeName(xCount) = "Boolean" Then Exit Sub
If TypeName(xID) = "Boolean" Then Exit Sub
If (xCount = "") Or (Not IsNumeric(xCount)) Or (xCount < 1) Or (xID < 1) Or (xCount = "") Or (Not IsNumeric(xID)) Then
MsgBox "error entered, please enter again", vbInformation, "Kutools for Excel"
GoTo LInput
Else
xScreen = Application.ScreenUpdating
Application.ScreenUpdating = False
For c = 0 To xCount - 1
ActiveSheet.Range("E2").Value = "JAC" & xJAC
ActiveSheet.Range("G2").Value = xID + c
ActiveSheet.PrintOut
Next
ActiveSheet.Range("E2").ClearContents
ActiveSheet.Range("G2").ClearContents
Application.ScreenUpdating = xScreen
End If
End Sub
I'm looking to have primary workbook (WorkbookA), open a second workbook (WorkbookB) and test for a value within it. Value to match is in WorkbookA, cell B3 and is the number 1. Range to test in WorkbookB is "A:A".
If the value is not found, WorkbookB is reopened for the user to edit (will optimize to reduce opening/closing, any ideas on getting user input to resume would be appreciated after editing Workbook B), and the code in WorkbookA loops and retests if WorkbookB is still open every 10 seconds.
After the user edits WorkbookB to ensure the value is present, they close it (any better way to signal they are complete is welcomed so I don';t have to close and reopen the files. They are small, so it's not an issue for speed, just seems inefficient).
The assumption I had was that the code would then detect the workbook was closed and then continue code execution, but the VBA is stopping as soon as I select the X in the top right corner of Workbook B.
Would prefer not having separate code in personal.xls file because of multiple users.
Thanks,
Aaron
Code in Workbook A:
Global Const strWBb As String = "C:\Users\ashepherd\Desktop\WorkbookB.xlsx"
Global Const strRng As String = "A:A"
Sub Validate()
' ***************************** CHECK WORKBOOKB FOR 1 IN COLUMN A:A *****************************
' Verify presence on item in second workbook
searchItem = ThisWorkbook.Worksheets("Sheet1").Range("B3").Value
Do While Verify(searchItem, False) = False
Call Verify("", True)
Do While IsWorkBookOpen(strWBb) = True
endTime = DateAdd("s", 10, Now())
Do While Now() < endTime
DoEvents
Loop
Loop
Debug.Print "Workbook closed"
Loop
Debug.Print "search item found"
End Sub
Function Verify(item, OpenOnly As Boolean) As Boolean
' ****************************************************************************
' Open workbook B and verify that presence of item
' ****************************************************************************
Dim wbVerify As Workbook
Dim rng1 As Range
' ************************** OPEN FILE ************************************************
If IsFile(strWBb) Then
Set wbVerify = Application.Workbooks.Open(FileName:=strWBb, UpdateLinks:=False, IgnoreReadOnlyRecommended:=True) ' Open WorkbookB
wbVerify.Worksheets("Sheet1").Select
Else
MsgBox " File path incorrect. Unable to open.", vbCritical
Exit Function
End If
' ************************** TEST FOR ITEM ************************************************
If OpenOnly = True Then ' Only opening the file for read/write. Not testing values.
MsgBox "Opening workbook so values can be added. Close when additions completed."
Else
MsgBox ("Workbook B opened. Testing value for " & item & " in column A:A in Workbook B")
Set rng1 = Range(strRng).Find(item, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
MsgBox item & " found !"
Verify = True
wbVerify.Close
GoTo item_found
Else
MsgBox (item & " not found in column A:A. Closing Workbook B. *****User will be promoted at this point to exit, or re-open the file to modify the values so search value is found in column A:A. Code SHOULD resume when Workbook B is closed. Currently VBA code execution in Workbook A is stopping when the 'X' is selected in top right window of Workbook B*****")
Verify = False
wbVerify.Close
End If
End If
Normal_exit:
Exit Function
item_found:
MsgBox "Verify code complete"
GoTo Normal_exit
End Function
Function IsWorkBookOpen(FileName As String)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function
Function IsFile(ByVal fName As String) As Boolean
'Returns TRUE if the provided name points to an existing file.
'Returns FALSE if not existing, or if it's a folder
On Error Resume Next
IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory)
End Function
Final code:
Global Const strWBb As String = "C:\Users\ashepherd\Desktop\WorkbookB.xlsx"
Global Const strRng As String = "A:A"
Global Complete As Boolean
Sub Validate()
' ***************************** CHECK WORKBOOK_B FOR 1 IN COLUMN A:A *****************************
' Verify presence on item in second workbook
searchItem = ThisWorkbook.Worksheets("Sheet1").Range("B3").Value
Do While Verify(searchItem) = False
Complete = False
UserForm1.Show vbModeless ' USerform has a single button which changes the global "Complete" variable to true
Do While Complete = False
DoEvents
Loop
UserForm1.Hide
Debug.Print "Manual Edit Complete, retesting"
Loop
End Sub
Function Verify(item) As Boolean
' Modified to close only upon finding search item vs. reopening it.
' ****************************************************************************
' Open workbook B and verify that presence of item
' ****************************************************************************
Dim wbVerify As Workbook
Dim rng1 As Range
' ************************** OPEN FILE ************************************************
If IsFile(strWBb) Then
Set wbVerify = GetWorkbook(strWBb)
If Not wbVerify Is Nothing Then
Debug.Print wbVerify.Name
End If
wbVerify.Worksheets("Sheet1").Select
Else
MsgBox " File path incorrect. Unable to open.", vbCritical
Exit Function
End If
' ************************** TEST FOR ITEM ************************************************
Set rng1 = Range(strRng).Find(item, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
Verify = True
GoTo item_found
Else
MsgBox (item & " not found in column A:A. A pop up form will show. Edit document and then hit RESUME button to continue checking. DO NOT exit via the close icon in the top right window of Excel as the code will stop running.")
Verify = False
End If
Normal_exit:
Exit Function
item_found:
'MsgBox (item & " found in WorkbookB, column A:A. Verify code complete")
wbVerify.Close Savechanges:=True
GoTo Normal_exit
End Function
Function IsFile(ByVal fName As String) As Boolean
'Returns TRUE if the provided name points to an existing file.
'Returns FALSE if not existing, or if it's a folder
On Error Resume Next
IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory)
End Function
Public Function GetWorkbook(ByVal sFullName As String) As Workbook
' https://stackoverflow.com/questions/9373082/detect-whether-excel-workbook-is-already-open, modified to add ignorereadonly and update links
Dim sFile As String
Dim wbReturn As Workbook
sFile = Dir(sFullName)
On Error Resume Next
Set wbReturn = Workbooks(sFile)
If wbReturn Is Nothing Then
Set wbReturn = Application.Workbooks.Open(FileName:=sFullName, UpdateLinks:=False, IgnoreReadOnlyRecommended:=True)
End If
On Error GoTo 0
Set GetWorkbook = wbReturn
End Function
I have the following code:
Public Function get_workbook() As String
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = False
fd.Title = "Please select the file."
fd.Show
get_workbook = fd.SelectedItems(1)
End Function
This works. However, if the user closes the dialog box once opened, there is an:
"Invalid procedure call or argument" error thrown.
How would I go about handling this error?
So for example, rather than that error being thrown, the function simply exits.
EDIT:
I use this code to get the user to open a file which also works.
Dim wb as Workbook
Set wb = Workbooks.Open(get_workbook(), ReadOnly:=True)
Add in an error handler. I used a select case so you can add other errors should they occur.
Public Function get_workbook() As String
On Error GoTo errcatch
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = False
fd.Title = "Please select the file."
fd.Show
get_workbook = fd.SelectedItems(1)
on error goto 0
Exit Function 'Stop code from going into error handler without an error
errcatch:
Select Case Err.Number 'Do something based on error number
Case 5
on error goto 0
Exit Function
End Select
End Function
Private Sub ButtonPath_Click()
Cells(1, 32).Value = FolderExplorer()
End Sub
Above is my UserForm's Code.
Below Code is My Module's FolderExplorer() Function.
'//Source : http://software-solutions-online.com/vba-folder-dialog/ , edited by me.
Public Function FolderExplorer()
Dim intResult As Integer
Dim strPath As String
Application.FileDialog(msoFileDialogFolderPicker).ButtonName _
= "Select Path"
'the dialog is displayed to the user
intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
'checks if user has cancled the dialog.
If intResult <> 0 Then
'dispaly message box
'Call MsgBox(Application.FileDialog(msoFileDialogFolderPicker _
).SelectedItems(1), _
vbInformation, "Selected Folder")
FolderExplorer() = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
End If
End Function
It seemed working well at first. When I press the button in userform, FolderExplorer Pops up. but when I select the folder path, the Folder Explorer pops up again, and when I select the folder path, the Folder Explorer pops up again.... eternally.
I have no loop in my code. How Can I solve this problem?
Thanks for your answer in advance.
You are calling FolderExplorer() recursively in FolderExplorer() = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1).
You should use FolderExplorer = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) to return the value.
Below is a simplified version of your code.
Public Function FolderExplorer()
Dim intResult As Integer
Dim strPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.ButtonName = "Select Path"
intResult = .Show
If intResult <> 0 Then
FolderExplorer = .SelectedItems(1)
End If
End With
End Function
Sub test()
thesentence = InputBox("Type the filename with full extension", "Raw Data File")
Range("A1").Value = thesentence
If Dir("thesentence") <> "" Then
MsgBox "File exists."
Else
MsgBox "File doesn't exist."
End If
End Sub
In this when i pickup the text value from the input box, it doesn't work. If however, if remove "the sentence" from If Dir() and replace it with an actual name in the code, it works. Can somebody help?
Note your code contains Dir("thesentence") which should be Dir(thesentence).
Change your code to this
Sub test()
thesentence = InputBox("Type the filename with full extension", "Raw Data File")
Range("A1").Value = thesentence
If Dir(thesentence) <> "" Then
MsgBox "File exists."
Else
MsgBox "File doesn't exist."
End If
End Sub
Use the Office FileDialog object to have the user pick a file from the filesystem. Add a reference in your VB project or in the VBA editor to Microsoft Office Library and look in the help. This is much better than having people enter full paths.
Here is an example using msoFileDialogFilePicker to allow the user to choose multiple files. You could also use msoFileDialogOpen.
'Note: this is Excel VBA code
Public Sub LogReader()
Dim Pos As Long
Dim Dialog As Office.FileDialog
Set Dialog = Application.FileDialog(msoFileDialogFilePicker)
With Dialog
.AllowMultiSelect = True
.ButtonName = "C&onvert"
.Filters.Clear
.Filters.Add "Log Files", "*.log", 1
.Title = "Convert Logs to Excel Files"
.InitialFileName = "C:\InitialPath\"
.InitialView = msoFileDialogViewList
If .Show Then
For Pos = 1 To .SelectedItems.Count
LogRead .SelectedItems.Item(Pos) ' process each file
Next
End If
End With
End Sub
There are lots of options, so you'll need to see the full help files to understand all that is possible. You could start with Office 2007 FileDialog object (of course, you'll need to find the correct help for the version you're using).
Correction to fileExists from #UberNubIsTrue :
Function fileExists(s_directory As String, s_fileName As String) As Boolean
Dim obj_fso As Object, obj_dir As Object, obj_file As Object
Dim ret As Boolean
Set obj_fso = CreateObject("Scripting.FileSystemObject")
Set obj_dir = obj_fso.GetFolder(s_directory)
ret = False
For Each obj_file In obj_dir.Files
If obj_fso.fileExists(s_directory & "\" & s_fileName) = True Then
ret = True
Exit For
End If
Next
Set obj_fso = Nothing
Set obj_dir = Nothing
fileExists = ret
End Function
EDIT: shortened version
' Check if a file exists
Function fileExists(s_directory As String, s_fileName As String) As Boolean
Dim obj_fso As Object
Set obj_fso = CreateObject("Scripting.FileSystemObject")
fileExists = obj_fso.fileExists(s_directory & "\" & s_fileName)
End Function
just get rid of those speech marks
Sub test()
Dim thesentence As String
thesentence = InputBox("Type the filename with full extension", "Raw Data File")
Range("A1").Value = thesentence
If Dir(thesentence) <> "" Then
MsgBox "File exists."
Else
MsgBox "File doesn't exist."
End If
End Sub
This is the one I like:
Option Explicit
Enum IsFileOpenStatus
ExistsAndClosedOrReadOnly = 0
ExistsAndOpenSoBlocked = 1
NotExists = 2
End Enum
Function IsFileReadOnlyOpen(FileName As String) As IsFileOpenStatus
With New FileSystemObject
If Not .FileExists(FileName) Then
IsFileReadOnlyOpen = 2 ' NotExists = 2
Exit Function 'Or not - I don't know if you want to create the file or exit in that case.
End If
End With
Dim iFilenum As Long
Dim iErr As Long
On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As #iFilenum
Close iFilenum
iErr = Err
On Error GoTo 0
Select Case iErr
Case 0: IsFileReadOnlyOpen = 0 'ExistsAndClosedOrReadOnly = 0
Case 70: IsFileReadOnlyOpen = 1 'ExistsAndOpenSoBlocked = 1
Case Else: IsFileReadOnlyOpen = 1 'Error iErr
End Select
End Function 'IsFileReadOnlyOpen
Function FileExists(fullFileName As String) As Boolean
FileExists = VBA.Len(VBA.Dir(fullFileName)) > 0
End Function
Works very well, almost, at my site. If I call it with "" the empty string, Dir returns "connection.odc"!! Would be great if you guys could share your result.
Anyway, I do like this:
Function FileExists(fullFileName As String) As Boolean
If fullFileName = "" Then
FileExists = False
Else
FileExists = VBA.Len(VBA.Dir(fullFileName)) > 0
End If
End Function
Function FileExists(fullFileName As String) As Boolean
FileExists = VBA.Len(VBA.Dir(fullFileName)) > 0
End Function
I'm not certain what's wrong with your code specifically, but I use this function I found online (URL in the comments) for checking if a file exists:
Private Function File_Exists(ByVal sPathName As String, Optional Directory As Boolean) As Boolean
'Code from internet: http://vbadud.blogspot.com/2007/04/vba-function-to-check-file-existence.html
'Returns True if the passed sPathName exist
'Otherwise returns False
On Error Resume Next
If sPathName <> "" Then
If IsMissing(Directory) Or Directory = False Then
File_Exists = (Dir$(sPathName) <> "")
Else
File_Exists = (Dir$(sPathName, vbDirectory) <> "")
End If
End If
End Function
Very old post, but since it helped me after I made some modifications, I thought I'd share. If you're checking to see if a directory exists, you'll want to add the vbDirectory argument to the Dir function, otherwise you'll return 0 each time. (Edit: this was in response to Roy's answer, but I accidentally made it a regular answer.)
Private Function FileExists(fullFileName As String) As Boolean
FileExists = Len(Dir(fullFileName, vbDirectory)) > 0
End Function
based on other answers here I'd like to share my one-liners that should work for dirs and files:
Len(Dir(path)) > 0 or Or Len(Dir(path, vbDirectory)) > 0 'version 1 - ... <> "" should be more inefficient generally
(just Len(Dir(path)) did not work for directories (Excel 2010 / Win7))
CreateObject("Scripting.FileSystemObject").FileExists(path) 'version 2 - could be faster sometimes, but only works for files (tested on Excel 2010/Win7)
as PathExists(path) function:
Public Function PathExists(path As String) As Boolean
PathExists = Len(Dir(path)) > 0 Or Len(Dir(path, vbDirectory)) > 0
End Function