I'm getting an Application-defined or object-defined error on my Msgbox line. I have both InputBox variables declared as String. I tried changing Sheets(sheetname1) to an actual sheet name but same error. I tried everything I know, I'm puzzled with this error. Any help is appreciated.
sheetname1 = Application.InputBox("Enter the name of your first sheet.")
sheetname2 = Application.InputBox("Enter the name of your second sheet.")
For i = 1 To 100
For j = 1 To 100
If Not Sheets(sheetname1).Cells(i, j).Value = Sheets(sheetname2).Cells(i, j).Value Then
Sheets(sheetname1).Select
Cells(i, j).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ans = MsgBox("Cells " & i & "," & j & " do not match." & vbNewLine & "The value on " & sheetname1 & " is " & Sheets(sheetname1).Cells(i, j).Value & " and the value on " & sheetname2 & " is " & Sheets("sheetname2").Cells(i, j).Value, vbOKCancel + vbQuestion)
If ans = vbCancel Then Exit Sub
Else
GoTo skip1
End If
skip1:
Next j
Next i
As #BruceWayne correctly identified, you're using undeclared variables. Use Option Explicit.
Let me rephrase that...
ALWAYS use Option Explicit
Simple: stick the words Option Explicit at the top of every single module you ever see, and VBA will refuse to compile code where you're using an undeclared variable.
In this instance, you're referring to i1 and j1, which both contain the non-value Empty, since they're undeclared and uninitialized variants.
Here are the variables you need to declare:
Dim i As Long
Dim j As Long
Dim ans As vbMsgBoxResult
Dim sheetName1 As String
Dim sheetName2 As String
Without Option Explicit, VBA happily compiles a typo and takes it as "oh, I've never seen that guy, must be a new variable!"
I'm trying to build an structure like this below.
where I have a loop and sometimes one of the loop steps can return error but I want to skip it and continue loop till the end.
But if any of the loops execution had error I want to know it printing in a cell something like "Missing loads: ( 1 ,20 ,36)" Where this number are unique values that one of my variables on the loop receive.
So I think every time one of my loop executions return error I need to build a list of this variable value and at the end of the loop process use this list to return this error msg.
UPDATE:
For the below I want to know the list of any eventual "sProdId" value that was in the SQL query wen it fail to execute by ANY error. Usually it try to insert #Value in a numeric SQL field.
Sub SavetoSQL()
Dim conn As New ADODB.Connection
Dim iRowNo As Integer
Dim Ddate
Ddate = Range("refdate")
Dim RngRefdate As Date
RngRefdate = DateSerial(Year(Ddate), Month(Ddate), Day(Ddate))
With Sheets("Hist Prods temp")
'Open a connection to SQL Server
conn.Open "Provider=SQLOLEDB;Data Source=XXXXX;Initial Catalog=XXXXXX;User Id=XXXX;Password=XXXXXXX;"
'Skip the header row
iRowNo = 2
'Loop until empty cell in sRefDate
Do Until .Cells(iRowNo, 1) = ""
sRefDate = .Cells(iRowNo, 1)
sProdId = .Cells(iRowNo, 2)
sPrice = .Cells(iRowNo, 3)
sValue = .Cells(iRowNo, 4)
sDV01 = .Cells(iRowNo, 5)
sDelta1 = .Cells(iRowNo, 6)
sDeltaPct = .Cells(iRowNo, 7)
sGamma = .Cells(iRowNo, 8)
sVega = .Cells(iRowNo, 9)
sTheta = .Cells(iRowNo, 10)
sDelta2 = .Cells(iRowNo, 11)
sIVol = .Cells(iRowNo, 12)
'Generate and execute sql statement to import the excel rows to SQL Server table
conn.Execute "INSERT INTO [dbo].[Prices] ([Date],[Id_Product],[Price],[Value],[DV01],[Delta1$],[Delta%],[Gamma$],[Vega$],[Theta$],[Delta2$],[Ivol],[Last_Update]) values ('" & sRefDate & "', '" & sProdId & "'," & sPrice & "," & sValue & "," & sDV01 & "," & sDelta1 & "," & sDeltaPct & "," & sGamma & "," & sVega & "," & sTheta & "," & sDelta2 & "," & sIVol & ",GETDATE())"
iRowNo = iRowNo + 1
Loop
conn.Close
Set conn = Nothing
End With
End Sub
Well you are a bit confused about Error Handling in VBA, have a look into Chip's website on proper Error Handling in VBA.
Your code should be something like,
Sub MyMacro()
On Error GoTo Errhandler
Dim errLog As String
Do Until
' My loop code
'Save variable X value in a list of error values.
Loop
ExitErrHandler:
If Len(errLog) > 0 Then
Range("M2") = "Missing loads: (" & Left(errLog, Len(errLog) - 2) & ")"
End If
Exit Sub
Errhandler:
'Make a Note of the Error Number and substitute it with 1234
If Err.Number = 1234 Then
' If an error occurs, display a message in a cell with all X values on the list.
errLog = errLog & yourUniqueValue & ", "
Resume Next
Else
MsgBox "Another Error occurred." & vbCrLf & vbCrLf & Err.Number & " - " & Err.Description
Resume ExitErrHandler
End If
End Sub
Your code makes no sense because you are turning off error handling (On Error GoTo 0) before you ever get to the loop code that would throw the error.
Here is one way to do it. I have my error handler inside the loop. It appends the x value to a string. Because x = x + 1 is in the error handler you don't have to worry about x not incrementing when you get an error. If you only care about certain Err.Number values, then change the if statement in my error handler. At the end of the code I print the error message to cell A1 of Sheet2 if and only if the error message string has at least one value. Otherwise I reset that output cell. On Error GoTo -1 is important to reset the error handler.
Sub MyMacro()
Dim x As Integer
Dim errMsg As String
Dim outWs As Worksheet
Set outWs = ThisWorkbook.Worksheets("Sheet1")
errMsg = ""
On Error GoTo CurrRecFail
x = 1
Do Until x = 15
' My loop code
CurrRecFail:
If Err.Number > 0 Then
errMsg = errMsg & x & ", "
End If
On Error GoTo -1
x = x + 1
Loop
If Len(errMsg) > 0 Then
outWs.Cells(1, 1).Value = "Missing Loads: " & Left(errMsg, Len(errMsg) - 2)
Else
outWs.Cells(1, 1).Value = ""
End If
End Sub
The code above will jump to the next loop iteration when it hits an error. If you wish instead to proceed through the rest of the lines in the current loop iteration, change On Error GoTo CurrRecFail to On Error Resume Next and delete the line CurrRecFail: which is now a meaningless label.
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.
I have this code with me where i can display the message when every outer loop ends. I want to catch all these messages in suppose array or soome list like structure and then at the end want to display each of these messages into one msgbox. Would appreciate if someone could help me.
Thanks.
For Each objNavFolder In objNavGroup.NavigationFolders
SkippedItemCounter = 0
If oItems.Count = 0 Then
MsgBox "No Appointments items in " & objNavFolder.DisplayName & "'s folder"
Else
NextRow = NextRow + 1
For Each MyItem In oItems
If MyItem = "" Then
SkippedItemCounter = SkippedItemCounter + 1
End If
'some code here
Next
Set objExpl = _colExpl.Add(objFolder, olFolderDisplayNormal)
NextRow = NextRow - 1
End If
MsgBox "No. of items= "&SkippedItemCounter&"skipped from"&objNavFolder.DisplayName&""
Next
End If
End If
End If
instead of calling msgboxes, create a String and keep adding the messages - at the end of code msgbox(yourString)
for example
decalare a string before the main sub
Dim yourFinalMessage As String ' or Dim yourFinalMessage$
instead of
MsgBox "No Appointments items in " & objNavFolder.DisplayName & "'s folder"
say
yourFinalMessage = yourFinalMessage & vbCrLf & & _
"No Appointments items in " & objNavFolder.DisplayName & "'s folder"
keep doing this until the loop ends.
at the end of loop say
msgbox YourFinalMessage
Not sure to exactly understand what you want, but you might try to add this to a module:
Option Explicit
Dim globalMsg as String
globalMsg = ""
Function customMsg(msg as String)
MsgBox msg
globalMsg = globalMsg & VbCrLf & msg
End Function
Just call customMsg("Your Message") to display a MsgBox and at the end, call MsgBox globalMsg to display all the messages as a single message (one per line). There are a lot of other ways to do this, it depends on you. Please be more explicit if you want any further help.
This is more an observation than a real question: MS-Access (and VBA in general) is desperately missing a tool where error handling code can be generated automatically, and where the line number can be displayed when an error occurs. Did you find a solution? What is it? I just realized how many hundreds of hours I spared since I found the right answer to this basic problem a few years ago, and I'd like to see what are your ideas and solutions on this very important issue.
What about using "Erl", it will display the last label before the error (e.g., 10, 20, or 30)?
Private Sub mySUB()
On Error GoTo Err_mySUB
10:
Dim stDocName As String
Dim stLinkCriteria As String
20:
stDocName = "MyDoc"
30:
DoCmd.openform stDocName, acFormDS, , stLinkCriteria
Exit_mySUB:
Exit Sub
Err_mySUB:
MsgBox Err.Number & ": " & Err.Description & " (" & Erl & ")"
Resume Exit_mySUB
End Sub
My solution is the following:
install MZ-Tools, a very interesting add-on for VBA. No they did not pay me to write this. Version 3 was free, but since version 8.0, the add-in is commercially sold.
program a standard error handler code such as this one (see MZ-Tools menu/Options/Error handler):
On Error GoTo {PROCEDURE_NAME}_Error
{PROCEDURE_BODY}
On Error GoTo 0
Exit {PROCEDURE_TYPE}
{PROCEDURE_NAME}_Error:
debug.print "#" & Err.Number, Err.description, "l#" & erl, "{PROCEDURE_NAME}", "{MODULE_NAME}"
This standard error code can be then automatically added to all of your procs and function by clicking on the corresponding button in the MZ-Tools menu. You'll notice that we refer here to a hidden and undocumented function in the VBA standard library, 'Erl', which stands for 'error line'. You got it! If you ask MZ-Tools to automatically number your lines of code, 'Erl' will then give you the number of the line where the error occured. You will have a complete description of the error in your immediate window, such as:
#91, Object variable or With block variable not set, l# 30, addNewField, Utilities
Of course, once you realize the interest of the system, you can think of a more sophisticated error handler, that will not only display the data in the debug window but will also:
display it as a message on the screen
Automatically insert a line in an error log file with the description of the error or
if you are working with Access or if you are connected to a database, automatically add a record to a Tbl_Error table!
meaning that each error generated at the user level can be stored either in a file or a table, somewhere on the machine or the network. Are we talking about building an automated error reporting system working with VBA?
Well there are a couple of tools that will do what you ask MZ Tools and FMS Inc come to mind.
Basically they involve adding an:
On Error GoTo ErrorHandler
to the top of each proc
and at the end they put an:
ErrorHandler:
Call MyErrorhandler Err.Number, Err.Description, Err.LineNumber
label with usually a call to a global error handler where you can display and log custom error messages
You can always roll your own tool like Chip Pearson did. VBA can actually access it's own IDE via the Microsoft Visual Basic for Applications Extensibility 5.3 Library. I've written a few class modules that make it easier to work with myself. They can be found on Code Review SE.
I use it to insert On Error GoTo ErrHandler statements and the appropriate labels and constants related to my error handling schema. I also use it to sync up the constants with the actual procedure names (if the function names should happen to change).
There is no need to buy tools DJ mentioned. Here is my code for free:
Public Sub InsertErrHandling(modName As String)
Dim Component As Object
Dim Name As String
Dim Kind As Long
Dim FirstLine As Long
Dim ProcLinesCount As Long
Dim Declaration As String
Dim ProcedureType As String
Dim Index As Long, i As Long
Dim LastLine As Long
Dim StartLines As Collection, LastLines As Collection, ProcNames As Collection, ProcedureTypes As Collection
Dim gotoErr As Boolean
Kind = 0
Set StartLines = New Collection
Set LastLines = New Collection
Set ProcNames = New Collection
Set ProcedureTypes = New Collection
Set Component = Application.VBE.ActiveVBProject.VBComponents(modName)
With Component.CodeModule
' Remove empty lines on the end of the code
For i = .CountOfLines To 1 Step -1
If Component.CodeModule.Lines(i, 1) = "" Then
Component.CodeModule.DeleteLines i, 1
Else
Exit For
End If
Next i
Index = .CountOfDeclarationLines + 1
Do While Index < .CountOfLines
gotoErr = False
Name = .ProcOfLine(Index, Kind)
FirstLine = .ProcBodyLine(Name, Kind)
ProcLinesCount = .ProcCountLines(Name, Kind)
Declaration = Trim(.Lines(FirstLine, 1))
LastLine = FirstLine + ProcLinesCount - 2
If InStr(1, Declaration, "Function ", vbBinaryCompare) > 0 Then
ProcedureType = "Function"
Else
ProcedureType = "Sub"
End If
Debug.Print Component.Name & "." & Name, "First: " & FirstLine, "Lines:" & ProcLinesCount, "Last: " & LastLine, Declaration
Debug.Print "Declaration: " & Component.CodeModule.Lines(FirstLine, 1), FirstLine
Debug.Print "Closing Proc: " & Component.CodeModule.Lines(LastLine, 1), LastLine
' do not insert error handling if there is one already:
For i = FirstLine To LastLine Step 1
If Component.CodeModule.Lines(i, 1) Like "*On Error*" Then
gotoErr = True
Exit For
End If
Next i
If Not gotoErr Then
StartLines.Add FirstLine
LastLines.Add LastLine
ProcNames.Add Name
ProcedureTypes.Add ProcedureType
End If
Index = FirstLine + ProcLinesCount + 1
Loop
For i = LastLines.Count To 1 Step -1
If Not (Component.CodeModule.Lines(StartLines.Item(i) + 1, 1) Like "*On Error GoTo *") Then
Component.CodeModule.InsertLines LastLines.Item(i), "ExitProc_:"
Component.CodeModule.InsertLines LastLines.Item(i) + 1, " Exit " & ProcedureTypes.Item(i)
Component.CodeModule.InsertLines LastLines.Item(i) + 2, "ErrHandler_:"
Component.CodeModule.InsertLines LastLines.Item(i) + 3, " Call LogError(Err, Me.Name, """ & ProcNames.Item(i) & """)"
Component.CodeModule.InsertLines LastLines.Item(i) + 4, " Resume ExitProc_"
Component.CodeModule.InsertLines LastLines.Item(i) + 5, " Resume ' use for debugging"
Component.CodeModule.InsertLines StartLines.Item(i) + 1, " On Error GoTo ErrHandler_"
End If
Next i
End With
End Sub
Put it in a module and call it from Immediate Window every time you add new function or sub to a form or module like this (Form1 is name of your form):
MyModule.InsertErrHandling "Form_Form1"
It will alter your ode in Form1 from this:
Private Function CloseIt()
DoCmd.Close acForm, Me.Name
End Function
to this:
Private Function CloseIt()
On Error GoTo ErrHandler_
DoCmd.Close acForm, Me.Name
ExitProc_:
Exit Function
ErrHandler_:
Call LogError(Err, Me.Name, "CloseIt")
Resume ExitProc_
Resume ' use for debugging
End Function
Create now in a module a Sub which will display the error dialog and where you can add inserting the error to a text file or database:
Public Sub LogError(ByVal objError As ErrObject, moduleName As String, Optional procName As String = "")
On Error GoTo ErrHandler_
Dim sql As String
MsgBox "Error " & Err.Number & " Module " & moduleName & Switch(procName <> "", " in " & procName) & vbCrLf & " (" & Err.Description & ") ", vbCritical
Exit_:
Exit Sub
ErrHandler_:
MsgBox "Error in LogError procedure " & Err.Number & ", " & Err.Description
Resume Exit_
Resume ' use for debugging
End Sub
This code does not enter error handling if there is already "On Error" statement in a proc.
Love it Vlado!
I realize this is an old post, but I grabbed it and gave it a try, but I ran into a number of issues with it, which I managed to fix. Here's the code with fixes:
First of course, be sure to add the "Microsoft Visual Basic for Applications Extensibility 5.3" library to your project, and add these subroutines / modules to your project as well.
First, the module with the main code was named "modVBAChecks", and contained the following two subroutines:
To go through all modules (behind forms, sheets, the workbook, and classes as well, though not ActiveX Designers):
Sub AddErrorHandlingToAllProcs()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim lCtr As Long
StartNewWorksheetLog
Set VBProj = Workbooks("LabViewAnalysisTools.xla").VBProject
For Each VBComp In VBProj.VBComponents
If VBComp.Type <> vbext_ct_ActiveXDesigner Then
If VBComp.Name <> "modVBAChecks" And VBComp.Name <> "modLogToWorksheet" Then
AddToWksLog "============ Looking at Module """ & VBComp.Name & """"
'InsertErrHandling VBComp.Name
AddToWksLog
AddToWksLog
End If
End If
Next
MsgBox "Done!", vbSystemModal
End Sub
Then the modified version of your code (including a suggested change by
Rafał B.):
Public Sub InsertErrHandling(modsProcName As String)
' Modified from code submitted to StackOverflow by user Vlado, originally found
' here: https://stackoverflow.com/questions/357822/automatically-generating-handling-of-issues
Dim vbcmA As VBIDE.CodeModule
Dim ProcKind As VBIDE.vbext_ProcKind
Dim LineProcKind As VBIDE.vbext_ProcKind
Dim sProcName As String
Dim sLineProcName As String
Dim lFirstLine As Long
Dim lProcLinesCount As Long
Dim lLastLine As Long
Dim sDeclaration As String
Dim sProcType As String
Dim lLine As Long, lLine2 As Long
Dim sLine As String
Dim lcStartLines As Collection, lcLastlines As Collection, scProcsProcNames As Collection, scProcTypes As Collection
Dim bAddHandler As Boolean
Dim lLinesAbove As Long
Set lcStartLines = New Collection
Set lcLastlines = New Collection
Set scProcsProcNames = New Collection
Set scProcTypes = New Collection
Set vbcmA = Application.VBE.ActiveVBProject.VBComponents(modsProcName).CodeModule
' Remove empty lines on the end of the module. Cleanup, not error handling.
lLine = vbcmA.CountOfLines
If lLine = 0 Then Exit Sub ' Nothing to do!
Do
If Trim(vbcmA.Lines(lLine, 1)) <> "" Then Exit Do
vbcmA.DeleteLines lLine, 1
lLine = lLine - 1
Loop
lLine = vbcmA.CountOfDeclarationLines + 1
Do While lLine < vbcmA.CountOfLines
bAddHandler = False
' NOTE: ProcKind is RETRUNED from ProcOfLine!
sProcName = vbcmA.ProcOfLine(lLine, ProcKind)
' Fortunately ProcBodyLine ALWAYS returns the first line of the procedure declaration!
lFirstLine = vbcmA.ProcBodyLine(sProcName, ProcKind)
sDeclaration = Trim(vbcmA.Lines(lFirstLine, 1))
Select Case ProcKind
Case VBIDE.vbext_ProcKind.vbext_pk_Proc
If sDeclaration Like "*Function *" Then
sProcType = "Function"
ElseIf sDeclaration Like "*Sub *" Then
sProcType = "Sub"
End If
Case VBIDE.vbext_ProcKind.vbext_pk_Get, VBIDE.vbext_ProcKind.vbext_pk_Let, VBIDE.vbext_ProcKind.vbext_pk_Set
sProcType = "Property"
End Select
' The "lProcLinesCount" function will sometimes return ROWS ABOVE
' the procedure, possibly up until the prior procedure,
' and often rows BELOW the procedure as well!!!
lProcLinesCount = vbcmA.ProcCountLines(sProcName, ProcKind)
lLinesAbove = 0
lLine2 = lFirstLine - 1
If lLine2 > 0 Then
Do
sLineProcName = vbcmA.ProcOfLine(lLine2, LineProcKind)
If Not (sLineProcName = sProcName And LineProcKind = ProcKind) Then Exit Do
lLinesAbove = lLinesAbove + 1
lLine2 = lLine2 - 1
If lLine2 = 0 Then Exit Do
Loop
End If
lLastLine = lFirstLine + lProcLinesCount - lLinesAbove - 1
' Now need to trim off any follower lines!
Do
sLine = Trim(vbcmA.Lines(lLastLine, 1))
If sLine = "End " & sProcType Or sLine Like "End " & sProcType & " '*" Then Exit Do
lLastLine = lLastLine - 1
Loop
AddToWksLog modsProcName & "." & sProcName, "First: " & lFirstLine, "Lines:" & lProcLinesCount, "Last: " & lLastLine
AddToWksLog "sDeclaration: " & vbcmA.Lines(lFirstLine, 1), lFirstLine
AddToWksLog "Closing Proc: " & vbcmA.Lines(lLastLine, 1), lLastLine
If lLastLine - lFirstLine < 8 Then
AddToWksLog " --------------- Too Short to bother!"
Else
bAddHandler = True
' do not insert error handling if there is one already:
For lLine2 = lFirstLine To lLastLine Step 1
If vbcmA.Lines(lLine2, 1) Like "*On Error GoTo *" And Not vbcmA.Lines(lLine2, 1) Like "*On Error GoTo 0" Then
bAddHandler = False
Exit For
End If
Next lLine2
If bAddHandler Then
lcStartLines.Add lFirstLine
lcLastlines.Add lLastLine
scProcsProcNames.Add sProcName
scProcTypes.Add sProcType
End If
End If
AddToWksLog
lLine = lFirstLine + lProcLinesCount + 1
Loop
For lLine = lcLastlines.Count To 1 Step -1
vbcmA.InsertLines lcLastlines.Item(lLine), "ExitProc:"
vbcmA.InsertLines lcLastlines.Item(lLine) + 1, " Exit " & scProcTypes.Item(lLine)
vbcmA.InsertLines lcLastlines.Item(lLine) + 2, "ErrHandler:"
vbcmA.InsertLines lcLastlines.Item(lLine) + 3, " ShowErrorMsg Err, """ & scProcsProcNames.Item(lLine) & """, """ & modsProcName & """"
vbcmA.InsertLines lcLastlines.Item(lLine) + 4, " Resume ExitProc"
' Now replace any "On Error Goto 0" lines with "IF ErrorTrapping Then On Error Goto ErrHandler"
For lLine2 = lcStartLines(lLine) To lcLastlines(lLine)
sLine = vbcmA.Lines(lLine2, 1)
If sLine Like "On Error GoTo 0" Then
vbcmA.ReplaceLine lLine2, Replace(sLine, "On Error Goto 0", "IF ErrorTrapping Then On Error Goto ErrHandler")
End If
Next
lLine2 = lcStartLines.Item(lLine)
Do
sLine = vbcmA.Lines(lLine2, 1)
If Not sLine Like "* _" Then Exit Do
lLine2 = lLine2 + 1
Loop
vbcmA.InsertLines lLine2 + 1, " If ErrorTrapping Then On Error GoTo ErrHandler"
Next lLine
End Sub
And rather than pushing things to the Immediate window I used subroutines in a module I named "modLogToWorksheet", the full module being here:
Option Explicit
Private wksLog As Worksheet
Private lRow As Long
Public Sub StartNewWorksheetLog()
Dim bNewSheet As Boolean
bNewSheet = True
If ActiveSheet.Type = xlWorksheet Then
Set wksLog = ActiveSheet
bNewSheet = Not (wksLog.UsedRange.Cells.Count = 1 And wksLog.Range("A1").Formula = "")
End If
If bNewSheet Then Set wksLog = ActiveWorkbook.Worksheets.Add
lRow = 1
End Sub
Public Sub AddToWksLog(ParamArray sMsg() As Variant)
Dim lCol As Long
If wksLog Is Nothing Or lRow = 0 Then StartNewWorksheetLog
If Not (IsNull(sMsg)) Then
For lCol = 0 To UBound(sMsg)
If sMsg(lCol) <> "" Then wksLog.Cells(lRow, lCol + 1).Value = "'" & sMsg(lCol)
Next
End If
lRow = lRow + 1
End Sub
And finally, here's my Error Dialog generator:
Public Sub ShowErrorMsg(errThis As ErrObject, strSubName As String, strModName As String _
, Optional vbMBStyle As VbMsgBoxStyle = vbCritical, Optional sTitle As String = APP_TITLE)
If errThis.Number <> 0 Then
MsgBox "An Error Has Occurred in the Add-in. Please inform " & ADMINS & " of this problem." _
& vbCrLf & vbCrLf _
& "Error #: " & errThis.Number & vbCrLf _
& "Description: " & " " & errThis.Description & vbCrLf _
& "Subroutine: " & " " & strSubName & vbCrLf _
& "Module: " & " " & strModName & vbCrLf _
& "Source: " & " " & errThis.Source & vbCrLf & vbCrLf _
& "Click OK to continue.", vbMBStyle Or vbSystemModal, sTitle
End If
End Sub
Hope future users find it useful!