Access 2016 VBA Run-Time Errors - How to catch? - vba

Apologies in advance - This could be a long one - All Code added in the bottom.
I'm working on a database for tracking support tickets.
I've been trying to clear up the errors that have been popping up with the tracker - so I started working an rebuild - Cleaning code - Changing field names etc - It was an entirely new database that no one had access to. But for some reason, my error code doesn't seem to catch any more. So let me explain everything.
The front end is opened and on open, loads the login form - This utilizes DLOOKUP to check and match passwords - This is fine
After logging in, the ticket entry form loads (Frm_ticket_Entry) this has multiple fields for data and 2 buttons. (I'll only list a few as none are actually mandatory)
Field names:
Ticket_Number - (fairly self explanatory)
Agent - (Agent working ticket)
Return_Team - (if ticket was returned)
Buttons:
New Record - (Adds a new record - Guess you can tell that)
Save Record - (saves record after data changes)
When using Err.raise("error number") - My catcher works as expected
When I turn err.raise off (comment out) and run everything - I sometimes hit "Run-Time Errors" (Such as locked for editing) on my previous DB version - This was caught by my error catcher - and produced the custom output - Now, it does not seem to want to catch the run-time errors - Why not, what is going wrong!?
(apologies for the extensive read - I struggle to describe things accurately, but briefly. - Further info available if required / Requested)
Code for "New Record":
Private Sub btn_NewRecord_Click()
DoCmd.GoToRecord , , acNewRec 'Add a new record
Me.Ticket_Number = "#" ' Change ticket number textbox to "#"
Me.Kickback_Reason = "Pass to next level support" ' - Set Default entry for kick back reason
Me.Agent = User() ' Set "Agent" field to the currently logged in user
Me.Returning_Team = "CSC Service Desk" ' Set default for "Returning Team"
DoCmd.RunCommand acCmdSaveRecord 'Save the record into the table
DoCmd.GoToRecord acDataTable = tbl_Tickets, , acLast ' return to the last saved record
On Error GoTo Error_Handle
' Err.Raise 3314, "btn_New_Record_Click()", "Errored" ' Force error for debug purposes
' Err.Raise 2105, "btn_New_Record_Click()", "Errored"
' Err.Raise 21345, , "Unknown Error Occured"
Exit Sub
Error_Handle:
Call ErrorLogger(Err.Number, Err.Description, Err.Source)
Err.Clear
MsgBox "Error Trapping complete"
Resume Next
End Sub
And code for ErrorLogger:
Function ErrorLogger(ErrNum As Integer, ErrDesc, ErrSrc As String)
Select Case ErrNum
Case 3314 ' You must enter a value in the 'tblKickbacks.Ticket Number' field.
MsgBox "It seems some required fields may not have been completed! " _
& "Please ensure you have filled in 'Ticket Number' / 'Agent' / 'Returning Team' and/or 'Kickback Reason'"
If IsNull(Me.Ticket_Number) Then
Me.Ticket_Number.SetFocus
End If
If (MsgBox("Error " & ErrNum & " occured." & vbNewLine _
& "Details : " & ErrDesc & vbNewLine _
& "Error occured in : " & ErrSrc & vbNewLine _
& "Would you like to send an email error report?" _
, 4 Or 16, "ERROR DETECTED")) = vbYes _
Then
GoTo DevEmail
Else
GoTo Err_Exit
End If
Case 2105 ' You can't go to the specified record.
MsgBox "Error Caught - 2105"
Case 3218 ' Error Description: Could not update; currently locked.
' Need to find and add code here for forcibly unlocking any and ALL locked records
Case Else
MsgBox "Error : " & ErrNum & " -- " & ErrDesc & " " _
& "Not recognised - Sending error email"
GoTo DevEmail
End Select
DevEmail:
Dim oAPP As Outlook.Application
Dim oMail As Outlook.MailItem
' Create the Outlook session.
Set oAPP = New Outlook.Application
' Create the message.
Set oMail = oAPP.CreateItem(olMailItem)
With oMail
' Add the To recipient(s) to the message.
.To = "mwalker53#csc.com"
.Subject = "Tracker V2 Error"
.Body = "Error message as Follows:" & vbNewLine _
& "Error Number: " & ErrNum & vbNewLine _
& "Error Description: " & ErrDesc & vbNewLine _
& "Error Source: " & ErrSrc
.Send
End With
MsgBox "Email has been sent"
Err_Exit:
End Function

Move On Error GoTo Error_Handle at first line.
Private Sub btn_NewRecord_Click()
On Error GoTo Error_Handle
...
End Sub

There's nothing between on error goto errhandle and exit sub you need that line above the code that adds the new record

Related

Update a query by an item selected from a list - Double Click Event

I have a form called ConsultaInfo which display a list (LNome) of all partners name and I want to run a query that will bring back to the same form all the rest of information from the selected partner name from the that list.
My intention is when I double click the partner name, a query (ConsultaSocio) will be ran bringing all the other personal information from the selected partner from the Table Socios and then these information will be displayed on the right side of the same form.
Therefore, I would like to know how can I accomplish that.
There are several ways of doing this, all of which assuming that in addition to the name being displayed in the list box, there is also an ID field.
If the form is bound to the query, then you can use the .RecordsetClone to find the matching record and then set the Form's position:
Private Sub lstName_DblClick(Cancel As Integer)
On Error GoTo E_Handle
Me.RecordsetClone.FindFirst "ID=" & Me!lstName
Me.Bookmark = Me.RecordsetClone.Bookmark
sExit:
On Error Resume Next
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "ConsultaInfo!lstName_DblClick", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Another option is to change the Form's RecordSource property to only have that record:
Private Sub lstName_DblClick(Cancel As Integer)
On Error GoTo E_Handle
Me.RecordSource = "SELECT * FROM Socio WHERE ID=" & Me!lstName
sExit:
On Error Resume Next
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "ConsultaInfo!lstName_DblClick", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Regards,

Method ‘FindFirst’ of object ‘Recordset2’ failed. After not saving new record

In a form, create a new record, edit some data but before saving it use a combo box on the form to select another record to navigate to. This triggers the cboSalePicker_AfterUpdate. Then during this sub Form_BeforeUpdate executes. The user clicks no on the MsgBox to not save the new record. Then the rest of cboSalePicker_AfterUpdate is executed however the following error message is displayed:
Error Message
Error number -2147417848: Method ‘FindFirst’ of object ‘Recordset2’ failed.
Associated with the line Me.Recordset.FindFirst "[SaleID] = " & Str(Nz(cboSalePicker.Value, 0))
However, if the new record is saved no error is produced and the code performs as expected.
Form_BeforeUpdate
Private Sub Form_BeforeUpdate(Cancel As Integer)
On Error GoTo ErrorHandler
Dim strMsg As String
Dim iResponse As Integer
'Specify the mesage to display
strMsg = "Do you wish to save the changes?" & Chr(10)
strMsg = strMsg & "Click Yes to Save or No to Discard changes."
'Display the msg box
iResponse = MsgBox(strMsg, vbQuestion + vbYesNo, "Save Record?")
'Check response
If iResponse = vbNo Then
'Undo the change.
DoCmd.RunCommand acCmdUndo
'Cancel the update
Cancel = True
End If
Exit Sub
ErrorHandler:
MsgBox "Error number " & Err.Number & ": " & Err.Description
End Sub
cboSalePicker_AfterUpdate
Private Sub cboSalePicker_AfterUpdate()
On Error GoTo ErrorHandler
Me.Recordset.FindFirst "[SaleID] = " & Str(Nz(cboSalePicker.Value, 0))
Exit Sub
ErrorHandler:
MsgBox "Error number " & Err.Number & ": " & Err.Description
End Sub
Thanks
You are converting Your SaleID into a String using this
Str(Nz(cboSalePicker.Value, 0))
But your find first is looking for a number. If SaleID is a number then remove the Str() function from your code around the combobox value.
To show the concatenation try this
Private Sub cboSalePicker_AfterUpdate()
On Error GoTo ErrorHandler
Dim sCriteria as String
sCriteria = "[SaleID] = " & Nz(Me.cboSalePicker, 0)
debug.print sCriteria
Me.Recordset.FindFirst sCriteria
Exit Sub
ErrorHandler:
MsgBox "Error number " & Err.Number & ": " & Err.Description
End Sub
Comment out the first error handler line whilst you are debugging things.

When DoCmd.OpenForm opens a blank form because no record was found, display a message box that says record is not found

I have a MainMenu where the user can enter a SchoolID in a search bar (txtSearchBar) and when they click on the SearchBySchoolID button, it opens the form, SchoolForm, based on the SchoolID. Sometimes the user clicks the SearchBySchoolID button without entering anything in the txtSearchBar so when the code below is executed, SchoolForm still opens but it is all blank.
What can I add to my code below so that a message box saying "No SchoolID found" pops up instead of bringing the user to a blank SchoolForm when they type nothing into my search bar?
Private Sub SearchBySchoolID_Click()
Dim txtSearchBar As String
On Error GoTo ErrorIDSearch
DoCmd.OpenForm "SchoolForm", , , "SchoolID = " & ("""" &
Me.txtSearchBar.Value & """"), acFormReadOnly
ExitErrorIDSearch:
Exit Sub
ErrorSIDSearch:
If Err.Number = 3075 Then
MsgBox "Please enter a valid SchoolID."
Else
MsgBox "The following error has occured:" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & vbCrLf & _
"Error Description: " & Err.Description & vbCrLf & vbCrLf & , _
vbCritical, "An Error has Occured!"
Resume ExitErrorIDSearch
End If
End Sub
You have two choices
Either put your event handling in the OnOpen event of the form named SchoolForm (and maybe use OpenArgs or an invisible textbox to set some kind of Status on that form so it knows where it was opened from, and why)
or simpler:
Check for existence of the SchoolID in the table before attempting to open SchoolForm
Could use a DLookup or a DCount
e.g.
If DCount("SchoolID", "YourTableOrQueryForSchools", "SchoolID=" & """" & Me.txtSearchBar.Value & """") = 0 Then
MsgBox "Please enter a valid SchoolID.", 64, "Try Again"
Me.txtSearchBar = ""
Me.txtSearchBar.Setfocus
Else
DoCmd.OpenForm "SchoolForm", , , "SchoolID = " & """" & Me.txtSearchBar.Value & """", acFormReadOnly
End If

Excel VBA & VB6 Printer

I have the following code, this code was written in VB6 but i can not open the form or check any references.
Private Sub PopulatePrinterCombo(cmbDestination As ComboBox)
Dim objPrinter As Printer 'a printer in the Printers collection object
'Add the printers to the combo box
For Each objPrinter In printers
cmbPrinter.AddItem objPrinter.DeviceName
Next
'Set current selection to the default printer
cmbDestination.Text = Printer.DeviceName
End Sub
I am currently copying the code onto Excel VBA macro, the problem is the Dim objPrinter As Printer code, i keep getting an error message saying "USER DEFINED TYPE NOT DEFINED", do i need a reference to add on VBA to be able to get the option of declaring a variable as a "Printer" or something?
My second question is that i do not fully understand the "Printers" in the line For Each objPrinter In printers, what is "Printers"? can someone please explain that to me.
Thank you
PART 2
I am now trying to print files, i have the following as my code:
'Initialize values
intDraftsPrinted = 0
If objDraftPaths.Count > 1 Then
Else
intSelectedDraftCount = CountSelectedDrafts
End If
'prompt user to make sure
intMsgBoxResponse = MsgBox("You selected " & intSelectedDraftCount & " part numbers. After removing duplicates" & vbNewLine & "there were " & objDraftPaths.Count & " unique draft files found." & vbNewLine & "Do you want to print these files?", vbYesNo, "TD Printer")
If intMsgBoxResponse <> vbYes Then
intSelectedDraftCount = 0 'So the following for loop will not entered
Else
intSelectedDraftCount = objDraftPaths.Count
End If
For i = 1 To intSelectedDraftCount
booSuccess = False
'open the draft file
Set objDraftDocument = OpenSolidEdgeDraft(objDraftPaths.Item(i))
If objDraftDocument Is Nothing Then
'could not open file
MsgBox "Could not open the following draft file:" & vbNewLine & _
objDraftPaths.Item(i), vbExclamation, "Solid Edge Error"
Else
'Print the draft file
For Each objSheet In objDraftDocument.Sheets
strSheetSize = DetermineSheetSize(objSheet)
If strSheetSize <> "" Then
'Determine orientation
If InStr(1, strSheetSize, "90") <> 0 Then
'Print as landscape
intOrientation = vbPRORLandscape
Else
'Print as portrait
intOrientation = vbPRORPortrait
End If
'Specify Sheet Size
Select Case Left(strSheetSize, 1)
Case "A"
intPaperSize = VBRUN.PrinterObjectConstants.vbPRPSLetter
Case "B"
intPaperSize = VBRUN.PrinterObjectConstants.vbPRPS11x17
Case "C"
intPaperSize = VBRUN.PrinterObjectConstants.vbPRPSCSheet
Case "D"
intPaperSize = VBRUN.PrinterObjectConstants.vbPRPSDSheet
Case "E"
intPaperSize = VBRUN.PrinterObjectConstants.vbPRPSESheet
Case Else
intPaperSize = VBRUN.PrinterObjectConstants.vbPRPSLetter
End Select
'Enable error handling
On Error Resume Next
'Activate the current sheet
objSheet.Activate
If Err Then
'Could not activate sheet
MsgBox "An error occurred while attempting to print: " & vbNewLine & objDraftPaths.Item(i) & vbNewLine & "The error was:" & vbNewLine & "Error Number: " & Err.Number & vbNewLine & "Error Description: " & Err.Description, vbExclamation, "Solid Edge Error"
Err.Clear
Else
'Print to the printer specified by the combo box
objDraftDocument.PrintOut cmbPrinter.Text, 1, intOrientation, intPaperSize, , , , igPrintSelected
If Err Then
'Could not print document
MsgBox "An error occurred while attempting to print: " & vbNewLine & objDraftPaths.Item(i) & vbNewLine & "The error was:" & vbNewLine & "Error Number: " & Err.Number & vbNewLine & "Error Description: " & Err.Description, vbExclamation, "Solid Edge Error"
Err.Clear
Else
booSuccess = True
End If
End If
'Disable error handling
On Error GoTo 0
End If
Next
'Close the file
objDraftDocument.Close False
intDraftsPrinted = intDraftsPrinted + 1
End If
Next i
'Dereference objects
Set objSheet = Nothing
Set objDraftDocument = Nothing
'Set objDraftPaths = Nothing
PrintSelectedDrafts = intDraftsPrinted
Now the problem comes when i hits the line that says: intOrientation = vbPRORLandscape
in excel VBA, it does not recognize "vbPRORLandscape" as well as the next line "vbPRORPortrait". Is there a way to fix that?
Also, i have a feeling that VBRUN.PrinterObjectConstants.vbPRPSLetter and the rest of those lines might not work out as well. It works in VB6 though.
Thank you
It appears the Printers Collection is available in the MS Access VBA environment but I do not believe it is intrinsic to the Excel VBA environment.
I use the WshNetwork object of Windows Script Host to list the available printers. I use the subroutine below to populate a ComboBox with the list of printers that are connected to the system. In order for this code to work you will need to add the "Windows Script Host Object Model" reference to your VBA project. (Menu: Tools > References [Select from list])
I added the (j) loop to alphabetize the list.
Sub populatePrintersList()
Dim nwo As New WshNetwork
Dim i As Integer
Dim j As Integer
Dim bAdd As Boolean
bAdd = True
cmbPrinter.Clear
For i = 0 To (nwo.EnumPrinterConnections.Count / 2) - 1
For j = 0 To cmbPrinter.ListCount - 1
If nwo.EnumPrinterConnections(i * 2 + 1) < cmbPrinter.List(j) Then
cmbPrinter.AddItem nwo.EnumPrinterConnections(i * 2 + 1), j
bAdd = False
Exit For
End If
Next j
If bAdd Then cmbPrinter.AddItem nwo.EnumPrinterConnections(i * 2 + 1): bAdd = True
Next i
cmbPrinter.ListIndex = 0
End Sub
Part 2:
MSDN contains reference material for the Worksheet.PrintOut method: Worksheet.PrintOut
In depth documentation for the methods and properties of the Worksheet.PageSetup object can also be found on MSDN: Worksheet.PageSetup
I suggest using these resources to find a plethora of answers.

Detailed QueryTables Error Handling

Good Afternoon,
I am looking for a way to handle QueryTable Errors. I have looked at other questions on google and stackoverflow, however they do not appear to answer the specific question i am trying to ask.
Basically, is there a way to determine what the specific error was when handling a QueryTables error?
Code:
On Error Goto queryError
With Activesheet.QueryTables...
....
End With
queryError:
Msgbox("There was an error with the QueryTables. The reason for the error was: " & myError)
Is there a way to set myError to give more details specific to what the problem was, even if it means selecting some sort of status code? eg
QueryTables.StatusCode...
or something?
Thanks in advance.
How to handle errors:
Excel VBA doesn't supportTry Catch Finally. Instead, it uses On Error GoTo
For full control over error-handling in Excel you must use labels (which always end in a colon).
In this example, the two labels are:
tryAgain:
queryError:
Assume that the Query Table being created is from a text file that looks something like:
When you first run the routine, the user is prompted for three inputs:
Filepath
New Table Name
Cell (i.e. Range) to paste into
If an error occurs on any of these inputs, the code will immediately go to the label queryError:
So, say the user didn't enter in a valid filepath, it would look something like this:
If the user clicks Yes (to try again), then Resume tryAgain will take the code back up to that label and go through it all over.
Pay attention to the Select Case at the end. This is how you can control how you want to handle specific errors.
Here is the code to paste in a module:
Option Explicit
Sub CreateQueryTable()
'Assign values to these variables by prompting user with Input Boxes
Dim filepath As String
Dim qryTableName As String
Dim startCellForTable As Range
'These variables are used in the error handling prompts
Dim Msg As String
Dim Ans As Integer
'If an error occurs, code will go to the label `queryError:`
On Error GoTo queryError
tryAgain:
'Prompt user for the filename of the .txt file to use as QueryTable Source
filepath = InputBox("Please enter filepath of text file to use as the source")
'Prompt user to name the new Query Table
qryTableName = InputBox("Please enter name of Query Table")
'Prompt user for the cell to put table at
Set startCellForTable = Application.InputBox(Prompt:="Please select a cell where you would like to paste the table to", Type:=8)
'If user hits OK, check to see that they at least put something as a value
If filepath <> "" And qryTableName <> "" And startCellForTable <> "" Then
'format filepath variable so can pass it as argument to QueryTables.Add
'Trim any leading or trailing spaces from qryTableName
filepath = "TEXT;" & filepath
qryTableName = Trim(qryTableName)
End If
'Create QueryTable at Range("A1")
With ActiveSheet.QueryTables.Add(Connection:=filepath, Destination:=Range(startCellForTable.Address))
.Name = qryTableName
.Refresh BackgroundQuery:=False
End With
'If there are no errors, exit the procedure (so the `queryError:` code won't execute)
Exit Sub
queryError:
Msg = ""
'Say that an error occured
Msg = Msg & "An error occurred with the Query Table. " & vbNewLine & vbNewLine
'Use Excel's built-in Error object (named `Err`) to show error number and description of error
Msg = Msg & Err.Number & ": " & Error(Err.Number) & vbNewLine & vbNewLine
Select Case Err.Number
'Type mismatch
Case 13
'Object required
Case 424
Msg = Msg & vbNewLine & "Please check that a valid range was selected" & vbNewLine
'Application defined or Object defined error
Case 1004
Msg = Msg & vbNewLine & "Please check that this filepath is correct: " & vbNewLine & vbNewLine & filepath & vbNewLine
Case Else
End Select
'Prompt user to Try Again
Msg = Msg & vbNewLine & vbNewLine & "Try again?"
Ans = MsgBox(Msg, vbYesNo + vbCritical)
'If user says Yes, clear the error, and resume execution of code at label `TryAgain:`
If Ans = vbYes Then Resume tryAgain
End Sub