I want to catch my error handling statement only once, if it fails again, resume next. I'm not sure how to achieve that but so far i'm able to rerun the code if it keeps on failing. Reason is i don't want to get stuck in a loop if the file never exist. Here's what i have:
....some code
TryAgain:
....
....
If Not FileExists("C:\" & FileName) Then
GoTo TryAgain >>> Only want to run this once if it fails again continue on down with the next section of codes.
End If
....next code stuff....
.....Dim blnRetry as Boolean
blnRetry =true
TryAgain:
....
....
If Not FileExists("C:\" & FileName) Then
if blnRetry then
blnRetry=false
GoTo TryAgain
end if
End If
My rule about GoTo is that I only use it in an On Error statement. Consider using a Do..Loop and a counter. Here's an example
Sub Test()
Dim sFile As String
Dim lTryCnt As Long
Const lMAXTRYCNT As Long = 10
Do
sFile = InputBox("Enter file name")
lTryCnt = lTryCnt + 1
Loop Until sFile = "False" Or Len(Dir("C:\" & sFile)) > 0 Or lTryCnt >= lMAXTRYCNT
Debug.Print sFile, lTryCnt
End Sub
sfile = "False" is if the user clicks Cancel on the inputbox. Len(Dir()) returns a zero length string if the file doesn't exist.
Related
I'm mapping to the company's sharepoint drive using VBA. The intention is to save local file to sharepoint, and delete local file and unmapped the drive after success.
On my machine(Windows 10 64bits), the code works perfectly fine, successfully mapped the drive, created folder and file, successfully uploaded to sharepoint and unmap the drive.
However, when I run the same excel workbook that contains the same code on my colleague's computer(Window 7), it failed. There's no error being shown, except that it keeps on loading and loading until Excel Not Responsive. I tried manually mapping the drive, it success.
I tried to debug and found out that the code stops (keeps on loading) at MsgBox "Hello" but could not figure out what's missing.
Both are using Excel 2016
Any help and suggestions are appreciated. let me know if more info is needed. Thanks in advance.
This is my vba code
Sub imgClicked()
Dim fileName As String
Dim SharePointLib As String
Dim MyPath As String
Dim folderPath As String
Dim objNet As Object
Dim copyPath As String
Dim copyFilePath As String
folderPath = Application.ThisWorkbook.path
MyPath = Application.ThisWorkbook.FullName
Dim objFSO As Object
Dim strMappedDriveLetter As String
Dim strPath As String
Dim spPath As String
strPath = "https://company.com/sites/test/test 123/" 'example path
spPath = AvailableDriveLetter + ":\test.xlsm" 'example path
copyPath = folderPath + "\copyPath\"
'Add reference if missing
Call AddReference
Set objFSO = CreateObject("Scripting.FileSystemObject")
With objFSO
strMappedDriveLetter = IsAlreadyMapped(.GetParentFolderName(strPath))
If Not Len(strMappedDriveLetter) > 0 Then
strMappedDriveLetter = AvailableDriveLetter
If Not MapDrive(strMappedDriveLetter, .GetParentFolderName(strPath)) Then
MsgBox "Failed to map SharePoint directory", vbInformation, "Drive Mapping Failure"
Exit Sub
End If
End If
' Check file/folder path If statement here
End With
Set objFSO = Nothing
End Sub
Code for getting available drive
' Returns the available drive letter starting from Z
Public Function AvailableDriveLetter() As String
' Returns the last available (unmapped) drive letter, working backwards from Z:
Dim objFSO As Object
Dim i As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
For i = Asc("Z") To Asc("A") Step -1
Select Case objFSO.DriveExists(Chr(i))
Case True
Case False
Select Case Chr(i)
Case "C", "D" ' Not actually necessary - .DriveExists should return True anyway...
Case Else
AvailableDriveLetter = Chr(i)
Exit For
End Select
End Select
Next i
Set objFSO = Nothing
MsgBox "This is the next available drive: " + AvailableDriveLetter ' returns Z drive
MsgBox "Hello" ' After this msgBox, starts loading until Not Responsive
End Function
Function to Map drive
Public Function MapDrive(strDriveLetter As String, strDrivePath As String) As Boolean
Dim objNetwork As Object
If Len(IsAlreadyMapped(strDrivePath)) > 0 Then Exit Function
Set objNetwork = CreateObject("WScript.Network")
objNetwork.MapNetworkDrive strDriveLetter & ":", strDrivePath, False
MapDrive = True
MsgBox "Successfully Created the Drive!"
Set objNetwork = Nothing
End Function
Code for MappedDrive
Public Function GetMappedDrives() As Variant
' Returns a 2-D array of (1) drive letters and (2) network paths of all mapped drives on the users machine
Dim objFSO As Object
Dim objDrive As Object
Dim arrMappedDrives() As Variant
Dim i As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim arrMappedDrives(1 To 2, 1 To 1)
For i = Asc("A") To Asc("Z")
If objFSO.DriveExists(Chr(i)) Then
Set objDrive = objFSO.GetDrive(Chr(i))
If Not IsEmpty(arrMappedDrives(1, UBound(arrMappedDrives, 2))) Then
ReDim Preserve arrMappedDrives(1 To 2, 1 To UBound(arrMappedDrives, 2) + 1)
End If
arrMappedDrives(1, UBound(arrMappedDrives, 2)) = Chr(i) ' Could also use objDrive.DriveLetter...
arrMappedDrives(2, UBound(arrMappedDrives, 2)) = objDrive.ShareName
End If
Next i
GetMappedDrives = arrMappedDrives
Set objDrive = Nothing
Set objFSO = Nothing
End Function
Public Function IsAlreadyMapped(strPath As String) As String
' Tests if a given network path is already mapped on the users machine
' (Returns corresponding drive letter or ZLS if not found)
Dim strMappedDrives() As Variant
Dim i As Long
strMappedDrives = GetMappedDrives
For i = LBound(strMappedDrives, 2) To UBound(strMappedDrives, 2)
If LCase(strMappedDrives(2, i)) Like LCase(strPath) Then
IsAlreadyMapped = strMappedDrives(1, i)
Exit For
End If
Next i
Set objNetwork = Nothing
End Function
Add Reference
Sub AddReference()
'Macro purpose: To add a reference to the project using the GUID for the
'reference library
Dim strGUID As String, theRef As Variant, i As Long
'Update the GUID you need below.
strGUID = "{420B2830-E718-11CF-893D-00A0C9054228}"
'Set to continue in case of error
On Error Resume Next
'Remove any missing references
For i = ThisWorkbook.VBProject.References.Count To 1 Step -1
Set theRef = ThisWorkbook.VBProject.References.Item(i)
If theRef.isbroken = True Then
ThisWorkbook.VBProject.References.Remove theRef
End If
Next i
'Clear any errors so that error trapping for GUID additions can be evaluated
Err.Clear
'Add the reference
ThisWorkbook.VBProject.References.AddFromGuid _
GUID:=strGUID, Major:=1, Minor:=0
'If an error was encountered, inform the user
Select Case Err.Number
Case Is = 32813
'Reference already in use. No action necessary
Case Is = vbNullString
'Reference added without issue
Case Else
'An unknown error was encountered, so alert the user
MsgBox "A problem was encountered trying to" & vbNewLine _
& "add or remove a reference in this file" & vbNewLine & "Please check the " _
& "references in your VBA project!", vbCritical + vbOKOnly, "Error!"
End Select
On Error GoTo 0
End Sub
Procedure imgClicked is calling function AvailableDriveLetter multiple times. Remember that the function has to execute each time you refer to it.
I ran imgClicked (assuming that's the procedure you start with) and I was told, twice, "Next available letter = Z" and "Hello" and then it crashed Excel (perhaps getting stuck in a loop of creating FileSystem objects to look for an available drive letter?)
Try assigning AvailableDriveLetter to a variable (string) at the beginning of the procedure and referring to the variable each time you need the value, and see if you still have the issue.
(Remember to save before execution -- I get frustrated when troubleshooting "application hanging" issues because I keep forgetting to save my changes and then lose them on the crash!)
If this doesn't work, add a breakpoint (F9) on the End Function line after your "Hello" box and see if the code stops there. (I have trouble believing the MsgBox or End Function are the culprit.) If not, which procedure runs after that?
One more thing whether the issue is resolved or not:
Add Option Explicit at the very beginning of your module and then Compile the project and fix your missing variable declaration(s).
This is recommended whenever troubleshooting an issue as a means to eliminate variable declaration issues as a possible cause.
I need to write code that goes to a specific path and imports data from it,
then goes to another path and do the same.
I need that if path num 1 does not exist, it will jump direct to path num 2.
I wrote a sub for each path. there is a way to do something like:
if error goto sub ___ ?
Thanks in advance
Not directly, but you can do something like
On Error Goto error_sub1
and at the bottom of your function, write
error_sub1:
'ToDo - put your calling code here.
Elsewhere in you function you can switch the error handler to a different label:
On Error Goto error_sub2
and so on.
Try this:
Sub testSO()
On Error GoTo err
I=5/0
Exit Sub
err:
<your sub procedure here>
End Sub
Remember to include Exit Sub or else it will still run even without error!
Would it not be better to avoid the error in the first place and check whether the file exists before attempting to open it?
Sub Test()
Dim sFile1 As String
Dim sFile2 As String
Dim wrkBk As Workbook
On Error GoTo Error_Handler
sFile1 = "C:\Users\Desktop\MyFile1.xls"
sFile2 = "C:\Users\Desktop\MyFile2.xls"
If FileExists(sFile1) Then
Set wrkBk = Workbooks.Open(sFile1)
ElseIf FileExists(sFile2) Then
Set wrkBk = Workbooks.Open(sFile2)
Else
Err.Raise 513, , "File Not Found."
End If
wrkBk.Worksheets(1).Range("A1") = "Opened this file."
On Error GoTo 0
Fast_Exit:
'Any tidying up that needs doing.
Exit Sub
Error_Handler:
MsgBox Err.Description, vbExclamation + vbOKCancel, _
"Error: " & CStr(Err.Number)
Err.Clear
Resume Fast_Exit
End Sub
Public Function FileExists(ByVal FileName As String) As Boolean
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
FileExists = oFSO.FileExists(FileName)
End Function
I have a small problem with my code (MS Access VBA). It's not a big deal, but it's not something that should be seen with a cancellation request.
The initial part of the code allows me to extract the path and filename of an image which works beautifully.
Private Sub Image2_DblClick(Cancel As Integer)
'Source: http://stackoverflow.com/questions/14915179/ms-access-browse-for-file-and-get-file-name-and-path
Dim f As Object
Dim strFile As String
Dim strFolder As String
Dim varItem As Variant
Set f = Application.FileDialog(3)
f.AllowMultiSelect = False
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
strFolder = Left(varItem, Len(varItem) - Len(strFile))
TempVars.Add "imagePath2", strFolder & strFile
Next
End If
Set f = Nothing
The next portion inserts that string into the specified field in my query. This also works beautifully.
With DoCmd
.SetWarnings False
.OpenQuery "updateQueryVarietiesImage2"
.SetWarnings True
DoCmd.RunCommand acCmdRefresh
Me.Requery
End With
End Sub
The problem I am having is if I cancel selecting the image from the generated pop-up window. After cancelling I get "Run-time error '3464': Data type mismatch in criteria expression"
Clicking on "Debug" highlights
.OpenQuery "updateQueryVarietiesImage2"
I'm sure the error has to do with the fact that the query didn't run due to the cancellation, but I don't want the error to show up. What code should I be using to stop the error from coming up if the user hits Cancel?
Couldn't you just skip the code if no file is selected:
If f.SelectedItems.Count > 0 Then
With DoCmd
.SetWarnings False
.OpenQuery "updateQueryVarietiesImage2"
.SetWarnings True
.RunCommand acCmdRefresh
End With
Me.Requery
End If
I'm getting this error:
Run-time error '424' object required
when I try to run this code:
Sub SuperSaveAs()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim pathName As String
Dim myFileName As String
If (ActiveDocument.CustomDocumentProperties("_CheckOutSrcUrl").Value = True) Then
pathName = ActiveDocument.CustomDocumentProperties("_CheckOutSrcUrl").Value
myFileName = pathName + ActiveWorkbook.Name
ActiveWorkbook.SaveAs Filename:= _
myFileName _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Else
MsgBox "_CheckOutSrcUrl is missing"
End If
End Sub
This macro is connected with a button in Excel. The macro checks if the custom document property exists. If the custom document property exists the macro should save the file to the Value of _CheckOutSrcUrl (SharePoint Directory).
How can I fix the error?
You cannot use the above method to test whether a property name exists or not. There are two apparent approaches, and these are not my own personal answers:
Use a loop to examine all the property names and see if "_CheckOutSrcUrl" gets found. See https://answers.microsoft.com/en-us/office/forum/office_2007-word/using-customdocumentproperties-with-vba/91ef15eb-b089-4c9b-a8a7-1685d073fb9f
Use VBA error detection to see if the property "_CheckOutSrcUrl" exists. See http://www.vbaexpress.com/forum/showthread.php?15366-Solved-CustomDocumentProperties-Problem
A snippet example of #1 adapted to your code - would be best in a function:
Dim propertyExists As Boolean
Dim prop As DocumentProperty
propertyExists = False
For Each prop In ActiveDocument.CustomDocumentProperties
If prop.Name = "_CheckOutSrcUrl" Then
propertyExists = True
Exit For
End If
Next prop
A snippet example of #2 adapted to your code:
Dim propertyExists As Boolean
Dim tempObj
On Error Resume Next
Set tempObj = ActiveDocument.CustomDocumentProperties.Item("_CheckOutSrcUrl")
propertyExists = (Err = 0)
On Error Goto 0
Based on #Cybermike:
Function propertyExists(propName) As Boolean
Dim tempObj
On Error Resume Next
Set tempObj = ActiveDocument.CustomDocumentProperties.Item(propName)
propertyExists = (Err = 0)
On Error GoTo 0
End Function
I am currently experiencing an Issue with the On.Time() Command.
The Ontime offsetvalue is set to 00:00:10 checking if Files are open. (Sort of a realtime checker).
Sub MacroAutoRun1()
Dim RunTime1 As Date
RunTime1 = Now + TimeValue("00:10:00")
Application.OnTime RunTime1, "MacroAutoRun1"
If IsFileOpen("H:\Operations_Front_Office\Organisation Helpdesk & Renseignement\Test\1\Statistik.xlsm") Then
Interface.Interface_Statistik_Open_Val.Caption = "File in use"
Else
Interface.Interface_Statistik_Open_Val.Caption = "File currently not used"
End If
If IsFileOpen("H:\Operations_Front_Office\Organisation Helpdesk & Renseignement\Test\1\Timesheet.xlsm") Then
Interface.Interface_Timesheet_Open_Val.Caption = "File in use"
Else
Interface.Interface_Timesheet_Open_Val.Caption = "File currently not used"
End If
If IsFileOpen("H:\Operations_Front_Office\Organisation Helpdesk & Renseignement\Test\1\Datasheet_Roulement_Final_Original.xlsm") Then
Interface.Interface_Roulement_Open_Val.Caption = "File in use"
Else
Interface.Interface_Roulement_Open_Val.Caption = "File currently not used"
End If
IsFileOpen is a created function as per below:
Function IsFileOpen(FileName As String)
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: IsFileOpen = False
Case 70: IsFileOpen = True
Case Else: Error iErr
End Select
End Function
My Problem now is that while doing the check it seems other Procedures are not able to be completed such as:
If DateDfrHDSKMALADIE = 0 Then
Set FoundHDSKMaladie = Sheets("Congé + Maladie").Columns(1).Find(What:=Maladie1HDSKtxt, After:=Sheets("Congé + Maladie").Cells(1, 1))
X = FoundHDSKMaladie.Row
Y = FoundHDSKMaladie.Column + HDSKMALADIENumb
Sheets("Congé + Maladie").Cells(X, Y) = "M"
Then the FoundHDSKMaladie returns "Nothing" and it seems to me that the Find Method is not even applied.
Have you heard of such an issue? I would like to keep the search open in the Background (peferably), if that would not work I will then just revert to stopping the Timer when the Page is left and reactivate it when the User returns to the page.
Thanks in advance for your help.
I'm not sure why the method you are using are interuppting the other procedures, but I have used a similar things in the past using a workbook exists function. As the files that you are checking appear to be workbooks I'd suggest checking if using this function rather than the IsFileOpen function solves the issue. I beleive I saw this method in a excel/vba dummies book.
The string for the function would be "Statistik.xlsm" for example.
Function WorkbookExists(ByVal BookToCheck As String) As Boolean
Dim Path As String
On Error GoTo Find_Err
Path = Workbooks(BookToCheck).Saved
On Error GoTo 0
WorkbookExists = True
Exit Function
Find_Err:
WorkbookExists = False
End Function