I have a email (SendObject) routine in MSAccess VBA. The code crashes if the user decides not to commit to hit the send button, and simply closes the email form.
Private Sub ButtonSupportEmail_Click()
Dim varName As Variant
Dim varCC As Variant
Dim varSubject As Variant
Dim varBody As Variant
varName = "somebody#gmail.com"
varCC = "somebody#gmail.com"
varSubject = "ADB Front End Client Support_" & Now()
varBody = "Dear Amazing ADB Support Team:"
DoCmd.SendObject , , , varName, varCC, , varSubject, varBody, True, False
End Sub
Is there an error catch I can add that prompts (via a popup form) the user "No email sent" and closes gracefully?
Fig A: Error from user closing Outlook Email Form
Add error handling and ignore the 2501 - Operation cancelled error.
Private Sub ButtonSupportEmail_Click()
On Error GoTo Trap
Dim varName As Variant
Dim varCC As Variant
Dim varSubject As Variant
Dim varBody As Variant
varName = "somebody#gmail.com"
varCC = "somebody#gmail.com"
varSubject = "ADB Front End Client Support_" & Now()
varBody = "Dear Amazing ADB Support Team:"
DoCmd.SendObject , , , varName, varCC, , varSubject, varBody, True, False
Leave:
Exit Sub
Trap:
If Err.Number <> 2501 Then MsgBox Err.Description, vbCritical
Resume Leave
End Sub
Of course - use On Error Resume next and check Err.Number and Err.Description to catch and process the exception.
See https://learn.microsoft.com/en-us/dotnet/visual-basic/language-reference/statements/on-error-statement for more information.
Related
I am trying to assign an opened workbook to an workbook object. If that workbook is not already opened, then it throws an error. I am handling the errors using an Error Handler.
This works for me:
On Error GoTo OpenWorkbookError
Set Uwk = Application.Workbooks(WbkName)
OpenWorkbookError:
If Err <> 0 Then
Err.Clear
MsgBox ("Please Open the Required Workbook")
Exit Sub
End If
But is there a way to avoid using the error handlers in this situation.
One way to do it is check each workbook name, but what's wrong with the functions in the link that #SJR gave?
In your provided code you've kept the error handler within the main body of code - it should appear between the Exit Sub and End Sub at the end of the procedure.
Something like this would work without an error handler, but it's slower as it needs to check each workbook:
Sub Test()
Dim Uwk As Workbook
Dim WbkName As String
WbkName = "PERSONAL.XLSB"
For Each Uwk In Workbooks
If Uwk.Name = WbkName Then
Exit For
End If
Next Uwk
If Not Uwk Is Nothing Then
MsgBox Uwk.Name & " found!"
Else
MsgBox "Not found."
End If
End Sub
Your version of the code should have the error handler outside the main body:
Sub Test1()
Dim WbkName As String
Dim UWk As Workbook
WbkName = "PERSONAL1.XLSB"
On Error GoTo OpenWorkbookError
Set UWk = Workbooks(WbkName)
TidyExit:
'Close anything that needs closing and Exit.
Exit Sub '<< End of main body of procedure.
OpenWorkbookError:
Select Case Err.Number
Case 9 'Subscript out of range.
MsgBox "Please open the required workbook."
Resume TidyExit
Case Else
MsgBox "Error " & Err.Number & vbCr & _
Err.Description, vbOKOnly + vbCritical
Resume TidyExit
End Select
End Sub '<< End of procedure.
I can't find where the error is. A similar code to pull dynamic file name worked in another tab.
Sub MonthlyBCRCPL()
Dim filePath As String
Dim CardsRCPLWb As Workbook
Set CardsRCPLWb = ActiveWorkbook
filePath = CardsRCPLWb.Sheets("BCRCPL").Range("A1").Value
'Optimize Code
Call OptimizeCode_Begin
Const FlashFolder As String = "\\apacdfs\SG\GCGR\GROUPS\ASEAN\Dashboard\Cards\Flash\"
Flashname = Format(CardsRCPLWb.Sheets("ASEAN - CARDS, RCPL").Range("C2").Value, "YYYYMMDD")
Flashname = "ASEAN SD Regional Dashboard - " & Flashname & ".xlsx"
Flashpath = FlashFolder & Flashname
Dim FlashWb As Workbook
Set FlashWb = Workbooks.Open(Flashpath)
If FlashWb Is Nothing Then MsgBox "SD Flash File does not exist": Exit Sub
Consider handling the error in the subroutine and have it raise a message. Then, properly continues/skips/exits rest of code even releasing objects from memory caught during the exception. This is a best practice in VBA (and generally in programming).
I suspect the path cannot be found which looks to be a network UNC, file naming is not valid such as use of special characters, or workbook does not exist when trying to open:
Sub MonthlyBCRCPL()
On Error Goto ErrHandle:
...code...
ExitSubBlock:
Set CardsRCPLWb = Nothing
Set FlashWb = Nothing
Exit Sub
ErrHandle:
Msgbox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR"
Goto ExitSubBlock
' Resume Next
End Sub
I am trying to automate the tasks I would normally run through to compact my database, save backups, and update revision numbers for an automatic update system I am using. I am stuck on trying to make an accde file with a vba script.
Everything I find pertaining to the subject seems to point to using something like this.
function MakeACCDE(InPath As String, OutPath As String)
Dim app As New Access.Application
app.AutomationSecurity = msoAutomationSecurityLow
app.SysCmd 603, InPath, OutPath
End Function
A few users on various forums claim that this code works for them but I have not had any luck. My database runs the code without errors, but nothing actually happens.
Is there a particular piece of syntax I am not using or maybe something with the format of the file paths?
I found the following code at: http://www.experts-exchange.com/questions/28429044/How-do-I-create-an-Access-2010-accde-from-VBA.html
I inserted into my Access 2010 accdb, ran it, and it created an accde
**UPDATE: Seeing you want to run from a different DB, I tested that also... just change the line 'tmpDB_Full_Name = CurrentProject.FullName' to be your source database
Option Compare Database
Option Explicit
Function Create_MDE()
Dim tmpDB_Full_Name As String
Dim tmpDB_Name As String
Dim tmpDB_Backup_Full_Name As String
Dim tmpCopy_File As Variant
Dim tmpDirectory As String
'Call SetStartupOptions("AllowBypassKey", dbBoolean, False) '---This runs a procedure to deactivate the Shift & F11 key
'tmpDB_Full_Name = CurrentProject.FullName
tmpDB_Full_Name = "C:\data\access\MyDb.accdb"
tmpDirectory = CurrentProject.Path
tmpDB_Name = CurrentProject.Name
tmpDB_Backup_Full_Name = tmpDirectory & "\" & left(tmpDB_Name, Len(tmpDB_Name) - 6) & "-Backup.accdb"
'this removes a file created on the same day
If Dir(tmpDB_Backup_Full_Name) <> "" Then
Kill tmpDB_Backup_Full_Name
End If
'this creates a backup into destination tmpDirectory
If Dir(tmpDB_Backup_Full_Name) = "" Then
Set tmpCopy_File = CreateObject("Scripting.FileSystemObject")
tmpCopy_File.CopyFile tmpDB_Full_Name, tmpDB_Backup_Full_Name, True
End If
Dim app As New Access.Application
app.AutomationSecurity = msoAutomationSecurityLow
app.SysCmd 603, tmpDB_Backup_Full_Name, tmpDirectory & "\" & left(tmpDB_Name, Len(tmpDB_Name) - 9) & ".accde"
'Call SetStartupOptions("AllowBypassKey", dbBoolean, True) '---This runs a procedure to activate the Shift & F11
MsgBox ("Compile Complete!")
End Function
I have prepared a ready-made solution that creates an ACCDE file and at the same time allows you to protect it with a password. With frequent updates, it makes my life so much easier. I tested it on Microsoft Access 2016 and 2019.
The function SaveAccdbAsAccde() performs the following steps:
compiles and saves changes to the database
copies the database to '...(~temp~).ACCDB'
creates the file '...(~temp~).ACCDE'
if everything worked, it sets a password to the database and copies it as the target file
deletes working files
To protect the database with a password, do the following: SaveAccdbAsAccde("password")
I used a few functions that might also come in handy for other tasks:
helper functions based on Scripting.FileSystemObject for handling files use : CopyFile(),DeleteFile(),FileExists()
functions to secure / unsecure the database with a password EncryptDb() and DecryptDb()
All details below:
Option Explicit
'------------------------------------------------------------------------------------
'main function
Public Sub SaveAccdbAsAccde(Optional filePassword As String)
On Error Resume Next
Application.RunCommand acCmdCompileAndSaveAllModules
err.Clear
If err <> 0 Then MsgBox "Save changes in forms and reports before preparing the ACCDE file.": Exit Sub
On Error GoTo err_proc
Dim strFile0 As String, strFile1 As String, strFile2 As String, strFile3 As String
strFile0 = CurrentDb.Name
strFile1 = Replace(CurrentDb.Name, ".accdb", "(~temp~).accdb")
strFile2 = Replace(CurrentDb.Name, ".accdb", "(~temp~).accde")
strFile3 = Replace(CurrentDb.Name, ".accdb", ".accde")
If Not DeleteFile(strFile1) Then MsgBox "Can't felete file: " & strFile2: Exit Sub
If Not CopyFile(strFile0, strFile1) Then MsgBox "Can't copy file: " & strFile0 & " na " & strFile1: Exit Sub
If Not DeleteFile(strFile2) Then MsgBox "Can't delete file: " & strFile2: Exit Sub
MakeACCDESysCmd strFile1, strFile2
If Not FileExists(strFile2) Then MsgBox "Can't create file: " & strFile2: Exit Sub
If Not DeleteFile(strFile3) Then MsgBox "Can't delete file: " & strFile3: Exit Sub
EncryptDb strFile2, strFile3, filePassword
If Not FileExists(strFile3) Then MsgBox "Can't create file: " & strFile3: Exit Sub
If Not DeleteFile(strFile2) Then MsgBox "Can't delete file: " & strFile2: Exit Sub
If Not DeleteFile(strFile1) Then MsgBox "Can't delete file: " & strFile2: Exit Sub
MsgBox "Done: " & strFile3
exit_proc:
Exit Sub
err_proc:
MsgBox err.Description, vbCritical, "Error"
Resume exit_proc
End Sub
'------------------------------------------------------------------------------------
Public Sub EncryptDb(strSourcePath As String, strDestPath As String, pwd As String)
If pwd <> "" Then pwd = ";pwd=" & pwd
DBEngine.CompactDatabase strSourcePath, strDestPath, dbLangGeneral & pwd, dbVersion167, pwd
End Sub
Public Sub DecryptDb(strSourcePath As String, strDestPath As String, pwd As String)
If pwd <> "" Then pwd = ";pwd=" & pwd
DBEngine.CompactDatabase strSourcePath, strDestPath, dbLangGeneral & ";pwd=", dbVersion167, pwd
End Sub
Public Function MakeACCDESysCmd(InPath As String, OutPath As String)
Dim app As Access.Application
Set app = New Access.Application
app.AutomationSecurity = 1 'msoAutomationSecurityLow - Enables all macros. This is the default value when the application is started.
app.SysCmd 603, InPath, OutPath 'an undocumented action
app.Quit acQuitSaveNone
Set app = Nothing
End Function
'------------------------------------------------------------------------------------
Public Function CopyFile(strFromFile, strToFile)
On Error Resume Next
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
err.Clear
objFSO.CopyFile strFromFile, strToFile, True
CopyFile = err = 0
Set objFSO = Nothing
End Function
Public Function DeleteFile(strFile)
If Not FileExists(strFile) Then DeleteFile = True: Exit Function
On Error Resume Next
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
err.Clear
objFSO.DeleteFile strFile, True
DeleteFile = err = 0
Set objFSO = Nothing
End Function
Public Function FileExists(strFile)
On Error Resume Next
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
FileExists = objFSO.FileExists(strFile)
Set objFSO = Nothing
End Function
I have tested the following code in Access 2016 using ACCDE and ACCDR as the destination file extension:
Dim otherAccess As Access.Application
Set otherAccess = New Access.Application
otherAccess.AutomationSecurity = 1 'msoAutomationSecurityLow
otherAccess.SysCmd 603, InPath, OutPath
otherAccess.Quit acQuitSaveNone
Set otherAccess = Nothing
I am experiencing an issue with Outlook automation,
To keep it simple I will first show you a shorter version of my code :
Sub test()
Dim GetOutlookApp As Object
Set GetOutlookApp = CreateObject("Outlook.Application")
End Sub
First, I do want to keep the late binding solution.
This sub launch Outlook in the taskbar (small icon). When I double click on it, a message pops up: "No active explorer object found" (title of the window: "Error"). Then the Outlook Inbox window opens when I click on OK.
My script is for end users so I don't want this message appears even if the user just has to click on OK (the rest of the main sub has no one issue).
I have to solve this problem to be able to send an email with outlook and to make sure the email is not in the Outbox folder.
What I am looking for is a way to open outlook, without this message, using late binding.
Below is the full code to open outlook before sending the email (source: ron de bruin). It works perfectly except the outlook message. The message pops up on this line:
obj.Session.GetDefaultFolder(olFolderInbox).Display
I tried AppActivate and others stuffs but I did not succeed and can't find any info on google about that!
Thanks for your help
Sub send_mail ()
Dim OutApp As Object
Set OutApp = OutlookApp() 'OPEN OUTLOOK
'Set OutApp = CreateObject("Outlook.Application") 'OPEN OUTLOOK simple solution
With ActiveSheet.MailEnvelope
...
End With
End sub
Public Function OutlookApp( _
Optional WindowState As Long = olMaximized, _
Optional ReleaseIt As Boolean = True _
) As Object
'***This sub is a part to the global way to open outlook before sending an email (prevent the outbox bug, email stucked into the outbox)
'***Source: http://www.rondebruin.nl/win/s1/outlook/openclose.htm, late binding mode
Static obj As Object
On Error GoTo ErrHandler
Select Case True
Case obj Is Nothing, Len(obj.Name) = 0
Set obj = GetObject(, "Outlook.Application")
If obj.Explorers.Count = 0 Then
InitOutlook:
'Open inbox to prevent errors with security prompts
obj.Session.GetDefaultFolder(olFolderInbox).Display
obj.ActiveExplorer.WindowState = WindowState
End If
Case ReleaseIt
Set obj = Nothing
End Select
Set OutlookApp = obj
ExitProc:
Exit Function
ErrHandler:
Select Case Err.Number
Case -2147352567
'User cancelled setup, silently exit
Set obj = Nothing
Case 429, 462
MsgBox "Err.Number OutlookApp: " & Err.Number
Set obj = GetOutlookApp()
If obj Is Nothing Then
Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
Else
Resume InitOutlook
End If
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
End Select
Resume ExitProc
Resume
End Function
Private Function GetOutlookApp() As Object
'***This sub is a part to the global way to open outlook before sending an email (prevent the outbox bug, email stucked into the outbox)
'***Source: http://www.rondebruin.nl/win/s1/outlook/openclose.htm, late binding mode
'On Error GoTo ErrHandler
Set GetOutlookApp = CreateObject("Outlook.Application")
ExitProc:
Exit Function
ErrHandler:
Select Case Err.Number
Case Else
'Do not raise any errors
Set GetOutlookApp = Nothing
End Select
Resume ExitProc
Resume
End Function
Use the Add method of the Explorers class to create a new instance of the explorer window. Then you need to call the Display method of the Explorer class (not Folder).
Sub DisplayDrafts()
Dim myExplorers As Outlook.Explorers
Dim myOlExpl As Outlook.Explorer
Dim myFolder As Outlook.Folder
Set myExplorers = Application.Explorers
Set myFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set myOlExpl = myExplorers.Add(myFolder, olFolderDisplayNoNavigation)
myOlExpl.Display
End Sub
This sub launch Outlook in the taskbar (small icon). When I double click on it, a message pops up: "No active explorer object found" (title of the window: "Error"). Then the Outlook Inbox window opens when I click on OK.
Typically you shouldn't see any icons in the task bar. Make sure that you have all the latest updates and service packs installed for the OS and Outlook. Also check out the list of running processes before automating Outlook - make sure that no Outlook instances running at the moment.
See How to automate Outlook from another program for more information.
Using the Eugene Astafiev code I have solved my issue! Thanks Eugene!
Here is the code:
Sub that send the email:
Sub Send_Mail()
'**This sub aims to send the mail that contains the job sheet
'Deactivate the screen updating : increase the speed and looks better
Application.ScreenUpdating = False
'Select the range of data
ActiveSheet.Range(FirstCol_JS & 1 & ":" & LastCol_JS & Firstrow_JS + nb_item_scanned - 1).Select
'Show the envelope on the ActiveWorkbook. This line prevents a bug (Method 'MailEnveloppe' of object '_Worksheet' failed. -2147467259, 80004005)
ActiveWorkbook.EnvelopeVisible = True
'Make sure outlook is opened or open it *****HERE IS WHY MY QUESTION*****
Call OutlookApp <------------------------------------------------
'Email error handling
On Error GoTo ErrorManagement
With ActiveSheet.MailEnvelope
'Subject is the title of the mail
.Item.Subject = "Job Sheet"
'Introduction is the content of the mail
.Introduction = "Hi John," & vbCrLf & _
"..." & vbCrLf & _
"Regards, The computer"
.Item.To = "alias#domain.com"
.Item.Send
End With
'Select the home page (main sheet)
'It is needed to activate the screenupdating so that the userform can be displayed on the sheet1
Application.ScreenUpdating = True
Else
'Normally, this message should never appear
MsgBox "You can't create a job sheet without any item. Nothing was done.", , "Action not allowed"
End If
'Exit sub before the error handling codes
Exit Sub
ErrorManagement:
'Activate the screen updating : be able to show that the outlook interface disappears
Application.ScreenUpdating = True
'Hide the outlook interface
ActiveWorkbook.EnvelopeVisible = False
'Activate the Excel windows so that the msgbox does not appear in the Windows taskbar
'This line is mandatory because the outlook interface is in front of the Excel workbook when it appears, so we have to activate again the Excel worbook
Call ActivateExcel
End Sub
Principal sub that manage to open Outlook
Sub OutlookApp(Optional ReleaseIt As Boolean = True)
'***This sub is a part to the global way to open outlook before sending an email (prevent the outbox bug, email stucked into the outbox)
'***Source: http://www.rondebruin.nl/win/s1/outlook/openclose.htm, late binding mode, and Eugene Astafiev http://stackoverflow.com/questions/31198130/vba-outlook-no-active-explorer-found
'Declaration of an object for outlook. The static mode allows to keep the object when this sub is launched more than one time
Static olObject As Object 'Early binding: Outlook.Application
'Declaration of variable objects to open the outlook window (prevent the email to be stuck in the Outbox folder)
Dim myExplorers As Object 'Early binding: Outlook.Explorers
Dim myOlExpl As Object 'Early binding: Outlook.Explorer
Dim myFolder As Object 'Early binding: Outlook.Folder
'Error handling
On Error GoTo ErrHandler
Select Case True
'If the olObject is nothing then try to create it
Case olObject Is Nothing, Len(olObject.Name) = 0
'This line will work if outlook is already opened, otherwise it will create an error and the code will go to ErrHandler
Set olObject = GetObject(, "Outlook.Application")
'If there is not already one opened windows of outlook
If olObject.Explorers.Count = 0 Then
InitOutlook:
'Open outlook window to prevent the email to be stucked in the Outbox folder (not sent)
Set myExplorers = olObject.Explorers
Set myFolder = olObject.GetNamespace("MAPI").GetDefaultFolder(6) 'olFolderInbox: 6
Set myOlExpl = myExplorers.Add(myFolder, 0) 'olFolderDisplayNoNavigation: 2, olFolderDisplayNormal:0
'Early binding code:
'Set myExplorers = Application.Explorers
'Set myFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
'Set myOlExpl = myExplorers.Add(myFolder, olFolderDisplayNoNavigation)
myOlExpl.Display
End If
End Select
'Delete the olObject variable is the ReleaseIt boolean is true
If ReleaseIt = True Then
Set olObject = Nothing
End If
'Possibility to set the OutlookApp function as the outlook object, if OutlookApp is declared like this: "Function OutlookApp(Optional ReleaseIt As Boolean = True) as Object"
'Set OutlookApp = olObject
ExitProc:
Exit Sub
ErrHandler:
Select Case Err.Number
Case -2147352567
'User cancelled setup, silently exit
Set olObject = Nothing
Case 429, 462 '429: outlook was not opened, the Set olObject = GetObject(, "Outlook.Application") code line above did not work
Set olObject = CreateOutlook() 'Launch the CreateOutlook function: CreateOutlook = CreateObject("Outlook.Application")
If olObject Is Nothing Then 'If the outlook object is still empty it means that there is a more serious issue (outlook not installed on the computer for example)
Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
Else 'If olObject is no more nothing, go back to the code above and open the outlook window
Resume InitOutlook
End If
Case Else 'For any other error numbers
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
End Select
Resume ExitProc
Resume 'For debugging
End Sub
Second sub that manage to open outlook
Private Function CreateOutlook() As Object
'***This sub is a part to the global way to open outlook before sending an email (prevent the outbox bug, email stucked into the outbox)
'***Source: http://www.rondebruin.nl/win/s1/outlook/openclose.htm, late binding mode
'Error handling
On Error GoTo ErrHandler
Set CreateOutlook = CreateObject("Outlook.Application")
ExitProc:
Exit Function
ErrHandler:
Set CreateOutlook = Nothing
Resume ExitProc
Resume 'For debugging
End Function
FYI here is the code to activate the Excel window
Sub ActivateExcel()
'***This sub aims to activate Excel windows (so that it's in front of the windows)
'Set variable title equal to exact application window title
Dim ExcelTitleCaption As String
ExcelTitleCaption = Application.Caption
'Activate Microsoft Excel
AppActivate ExcelTitleCaption
End Sub
Thanks!! Topic solved
New to vba, trying an 'on error goto' but, I keep getting errors 'index out of range'.
I just want to make a combo box that is populated by the names of worksheets which contain a querytable.
For Each oSheet In ActiveWorkbook.Sheets
On Error GoTo NextSheet:
Set qry = oSheet.ListObjects(1).QueryTable
oCmbBox.AddItem oSheet.Name
NextSheet:
Next oSheet
I'm not sure whether the problem is related to nesting the On Error GoTo inside a loop, or how to avoid using the loop.
The problem is probably that you haven't resumed from the first error. You can't throw an error from within an error handler. You should add in a resume statement, something like the following, so VBA no longer thinks you are inside the error handler:
For Each oSheet In ActiveWorkbook.Sheets
On Error GoTo NextSheet:
Set qry = oSheet.ListObjects(1).QueryTable
oCmbBox.AddItem oSheet.Name
NextSheet:
Resume NextSheet2
NextSheet2:
Next oSheet
As a general way to handle error in a loop like your sample code, I would rather use:
on error resume next
for each...
'do something that might raise an error, then
if err.number <> 0 then
...
end if
next ....
How about:
For Each oSheet In ActiveWorkbook.Sheets
If oSheet.ListObjects.Count > 0 Then
oCmbBox.AddItem oSheet.Name
End If
Next oSheet
Actualy the Gabin Smith's answer needs to be changed a bit to work, because you can't resume with without an error.
Sub MyFunc()
...
For Each oSheet In ActiveWorkbook.Sheets
On Error GoTo errHandler:
Set qry = oSheet.ListObjects(1).QueryTable
oCmbBox.AddItem oSheet.name
...
NextSheet:
Next oSheet
...
Exit Sub
errHandler:
Resume NextSheet
End Sub
There is another way of controlling error handling that works well for loops. Create a string variable called here and use the variable to determine how a single error handler handles the error.
The code template is:
On error goto errhandler
Dim here as String
here = "in loop"
For i = 1 to 20
some code
Next i
afterloop:
here = "after loop"
more code
exitproc:
exit sub
errhandler:
If here = "in loop" Then
resume afterloop
elseif here = "after loop" Then
msgbox "An error has occurred" & err.desc
resume exitproc
End if
I do not want to craft special error handlers for every loop structure in my code so I have a way of finding problem loops using my standard error handler so that I can then write a special error handler for them.
If an error occurs in a loop, I normally want to know about what caused the error rather than just skip over it. To find out about these errors, I write error messages to a log file as many people do. However writing to a log file is dangerous if an error occurs in a loop as the error can be triggered for every time the loop iterates and in my case 80 000 iterations is not uncommon. I have therefore put some code into my error logging function that detects identical errors and skips writing them to the error log.
My standard error handler that is used on every procedure looks like this. It records the error type, procedure the error occurred in and any parameters the procedure received (FileType in this case).
procerr:
Call NewErrorLog(Err.number, Err.Description, "GetOutputFileType", FileType)
Resume exitproc
My error logging function which writes to a table (I am in ms-access) is as follows. It uses static variables to retain the previous values of error data and compare them to current versions. The first error is logged, then the second identical error pushes the application into debug mode if I am the user or if in other user mode, quits the application.
Public Function NewErrorLog(ErrCode As Variant, ErrDesc As Variant, Optional Source As Variant = "", Optional ErrData As Variant = Null) As Boolean
On Error GoTo errLogError
'Records errors from application code
Dim dbs As Database
Dim rst As Recordset
Dim ErrorLogID As Long
Dim StackInfo As String
Dim MustQuit As Boolean
Dim i As Long
Static ErrCodeOld As Long
Static SourceOld As String
Static ErrDataOld As String
'Detects errors that occur in loops and records only the first two.
If Nz(ErrCode, 0) = ErrCodeOld And Nz(Source, "") = SourceOld And Nz(ErrData, "") = ErrDataOld Then
NewErrorLog = True
MsgBox "Error has occured in a loop: " & Nz(ErrCode, 0) & Space(1) & Nz(ErrDesc, "") & ": " & Nz(Source, "") & "[" & Nz(ErrData, "") & "]", vbExclamation, Appname
If Not gDeveloping Then 'Allow debugging
Stop
Exit Function
Else
ErrDesc = "[loop]" & Nz(ErrDesc, "") 'Flag this error as coming from a loop
MsgBox "Error has been logged, now Quiting", vbInformation, Appname
MustQuit = True 'will Quit after error has been logged
End If
Else
'Save current values to static variables
ErrCodeOld = Nz(ErrCode, 0)
SourceOld = Nz(Source, "")
ErrDataOld = Nz(ErrData, "")
End If
'From FMS tools pushstack/popstack - tells me the names of the calling procedures
For i = 1 To UBound(mCallStack)
If Len(mCallStack(i)) > 0 Then StackInfo = StackInfo & "\" & mCallStack(i)
Next
'Open error table
Set dbs = CurrentDb()
Set rst = dbs.OpenRecordset("tbl_ErrLog", dbOpenTable)
'Write the error to the error table
With rst
.AddNew
!ErrSource = Source
!ErrTime = Now()
!ErrCode = ErrCode
!ErrDesc = ErrDesc
!ErrData = ErrData
!StackTrace = StackInfo
.Update
.BookMark = .LastModified
ErrorLogID = !ErrLogID
End With
rst.Close: Set rst = Nothing
dbs.Close: Set dbs = Nothing
DoCmd.Hourglass False
DoCmd.Echo True
DoEvents
If MustQuit = True Then DoCmd.Quit
exitLogError:
Exit Function
errLogError:
MsgBox "An error occured whilst logging the details of another error " & vbNewLine & _
"Send details to Developer: " & Err.number & ", " & Err.Description, vbCritical, "Please e-mail this message to developer"
Resume exitLogError
End Function
Note that an error logger has to be the most bullet proofed function in your application as the application cannot gracefully handle errors in the error logger. For this reason, I use NZ() to make sure that nulls cannot sneak in. Note that I also add [loop] to the second identical error so that I know to look in the loops in the error procedure first.
What about?
If oSheet.QueryTables.Count > 0 Then
oCmbBox.AddItem oSheet.Name
End If
Or
If oSheet.ListObjects.Count > 0 Then
'// Source type 3 = xlSrcQuery
If oSheet.ListObjects(1).SourceType = 3 Then
oCmbBox.AddItem oSheet.Name
End IF
End IF