Programmatically change all reports - vba

I have a function that logs when users run a report. It is set to run "on open". Is there a way to change the on open for all reports and forms at once?

This code loops through all forms:
Public Sub DoChangeModules()
Dim dstApp As Application
Dim dstDB As Database
Dim AO As Document
Set dstApp = Application
Set dstDB = dstApp.CurrentDb
' iterate forms's modules and insert code
Dim f As Form
Dim M As Module
Debug.Print "Modifying Modules:"
Debug.Print "Forms:"
For Each AO In dstDB.Containers("Forms").Documents
dstApp.DoCmd.OpenForm AO.Name, acViewDesign
Set f = dstApp.Forms(AO.Name)
Set M = f.Module
ProccessModule M
Set f = Nothing
dstApp.DoCmd.Close acForm, AO.Name, acSaveYes
Next AO
End Sub
Public Sub ProccessModule(M As Module)
Dim numLine As Long
Dim StartLine As Long, StartColumn As Long, EndLine As Long, EndColumn As Long
Debug.Print , , M.Name
' insert variable declaration
M.AddFromString "Private testVar As variant ' test addition of module-level variable"
' locate or create Load event procedure
StartLine = 0
StartColumn = 0
EndLine = 0
EndColumn = 0
If Not M.Find(" Form_Open(", StartLine, StartColumn, EndLine, EndColumn) Then
numLine = M.CreateEventProc("Open", "Form")
End If
numLine = M.ProcBodyLine("Form_Open", 0) ' 0 here is vbext_pk_Proc
M.InsertLines numLine + 1, "" & _
" ' Call of global function that logs user" & vbNewLine & _
" doLogUser testVar " & vbNewLine & _
" ' that function called with local module variable "
End Sub

Related

an object as parameter, it is freed when end sub?

Public Sub EliminaPedido(Num As Integer, Hoja1 As Worksheet)
and at main form:
Private Sub bBaja_Click()
Dim x10 As New Excel.Application
Dim ArchivoDestino As Workbook
Dim R As String
R = "Año " & Year(Now)
Set ArchivoDestino = x10.Workbooks.Open(Ruta & "\Registro pedidos.xlsx", 0)
Dim M As Integer
M = MsgBox("Desea eliminar el pedido " & Me.Range("H2").Value & " emitido a " & Me.Range("E11").Value & "?", vbExclamation + vbYesNo, "Pedidos de Elementos")
If M = 6 Then EliminaPedido Me.Range("H2").Value, ArchivoDestino.Worksheets(R)
ArchivoDestino.Close True
End Sub
When EliminaPedido ends, the object Hoja1 is freed or into that sub I must use set Hoja1 = Nothing?

Why does VBA doesn't reach data after Row number 65,000 when using DAO with SQL language?

I have a VBA module that receives a database object, worksheet name, and two column field names as parameters to make a SQL query into another Excel table that has over 1,000,000 rows with information. But when I was debugging I noticed that my VBA code does not return the info after the row number 65,000 (approximately). This is returning wrong info and not acting properly as expected.
So, how can I handle it in my existing code?
Here is my code:
Functions
Const diretorioSA = "C:\Users\Bosch-PC\Desktop\dbLEGENDAS_ELETROPAR\"
Const BaseEletro = "dbClientesEletropar.xlsb"
Const dbClientes = "CLIENTESLDA"
Public Function Number2Letter(ByVal ColNum As Long) As String
Dim ColumnNumber As Long
Dim ColumnLetter As String
ColumnNumber = ColNum
ColumnLetter = Split(Cells(1, ColumnNumber).Address, "$")(1)
Number2Letter = ColumnLetter
End Function
Public Function GetWorkbook(ByVal sFullName As String) As Workbook
Dim sFile As String
Dim wbReturn As Workbook
sFile = DIR(sFullName)
On Error Resume Next
Set wbReturn = Workbooks(sFile)
If wbReturn Is Nothing Then
Set wbReturn = Workbooks.Open(sFullName)
End If
On Error GoTo 0
Set GetWorkbook = wbReturn
End Function
Public Function ReplaceChars(ByVal str As String, ByVal Lista As String) As String
Dim buff(), buffChars() As String
ReDim buff(Len(str) - 1): ReDim buffChars(Len(Lista) - 1)
For i = 1 To Len(str): buff(i - 1) = Mid$(str, i, 1): Next
For i = 1 To Len(Lista): buffChars(i - 1) = Mid$(Lista, i, 1): Next
For strEle = 0 To UBound(buff)
For listaEle = 0 To UBound(buffChars)
If buff(strEle) = buffChars(listaEle) Then
buff(strEle) = ""
End If
Next listaEle
novoTexto = novoTexto & buff(strEle)
Next strEle
ReplaceChars = novoTexto
End Function
Function ConsultaBaseDeDadosELETRO(ByVal CAMPO_PESQUISA As String, _
ByVal CAMPO_RETORNO As String, _
ByVal NOME_PLANILHA As String, _
ByRef BASES As Object, _
ByVal ARGUMENTO As String) As String
On Error GoTo ERRO:
Debug.Print BASES.Name
Dim RSt22 As Recordset
Set RSt22 = BASES.OpenRecordset("SELECT [" & CAMPO_RETORNO & "] FROM [" & NOME_PLANILHA & "$] WHERE [" & CAMPO_PESQUISA & "] IN ('" & ARGUMENTO & "') ;", dbOpenForwardOnly, dbReadOnly)
Debug.Print RSt22.CacheSize & " | CONTAGEM: " & RSt22.RecordCount
ConsultaBaseDeDadosELETRO = RSt22(CAMPO_RETORNO)
Exit Function
ERRO:
Debug.Print VBA.Err.Description & " | Error number: " & VBA.Err.Number & " | " & VBA.Err.HelpFile
ConsultaBaseDeDadosELETRO = "Sem registros"
End Function
Main Subroutine
Sub ProcurarBaseEletro(ByVal PASTA As String, ByVal ARQUIVO As String, ByVal NOME_PLANILHA As String, ByVal CAMPO As String)
If ActiveCell.value = "CGC" Or ActiveCell.value = "CNPJ" Or ActiveCell.value = "cgc" Or ActiveCell.value = "cnpj" Then
Application.ScreenUpdating = False
Dim wks As Worksheet: Set wks = ActiveSheet
Dim db2 As database
Dim CellRow As Single
Dim Cellcol_info, CellCol As String
Dim DiretorioBase As String: DiretorioBase = diretorioSA & BaseEletro
Dim wb As Workbook: Set wb = GetWorkbook(DiretorioBase)
If wb Is Nothing Then
MsgBox "Base de dados não localizada!" & vbNewLine & "EM: " & DiretorioBase, vbCritical, "Atenção"
Set wb = Nothing
Set wks = Nothing
Application.ScreenUpdating = True
Exit Sub
Else
wks.Activate
CellRow = ActiveCell.row
CellCol = Number2Letter(ActiveCell.Column)
Cellcol_info = Number2Letter(ActiveCell.Column + 1)
CELLCOL_LROW = ActiveSheet.Cells(ActiveSheet.Rows.Count, CellCol).End(xlUp).row
Set db2 = OpenDatabase(DiretorioBase, False, False, "Excel 8.0")
Columns(Cellcol_info & ":" & Cellcol_info).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cellcol_info & CellRow).value = CAMPO
Dim Query As String
Dim CelAtivaValue As String
For i = CellRow + 1 To CELLCOL_LROW
CelAtivaValue = UCase(Cells(i, CellCol).value)
Query = ReplaceChars(CelAtivaValue, "/.- ")
If Left(Query, 6) < 132714 Then
Cells(i, Cellcol_info).value = ConsultaBaseDeDadosELETRO("CGC", CAMPO, NOME_PLANILHA, db2, Query)
Else
Cells(i, Cellcol_info).value = ConsultaBaseDeDadosELETRO("CGC", CAMPO, NOME_PLANILHA & 2, db2, Query)
End If
Next i
wb.Close
End If
Else
MsgBox "Texto da Célula ativa não é CGC/CNPJ, impossível fazer pesquisa", vbCritical, "Valor célula ativa: " & ActiveCell.value
Application.ScreenUpdating = True
Exit Sub
End If
Cells.EntireColumn.AutoFit
MsgBox "Processo concluído com sucesso.", vbOKOnly, "Informativo do sistema"
Application.ScreenUpdating = True
End Sub
Older Excel formats (.xls) maintains a worksheet limit of 2^16 (65536) rows. Current Excel formats (.xlsx) maintains a worksheet limit of 2^20 (1,048,576) rows.
Likely, you have a more recent version of MS Office (2007+) (given the .xlsb in BaseEletro) but your DAO code was not updated. Consider adjusting the DAO.OpenDatabase option to the newer current format.
From
Set db2 = OpenDatabase(DiretorioBase, False, False, "Excel 8.0")
To
Set db2 = OpenDatabase(DiretorioBase, False, False, "Excel 12.0 Xml")

Is it possible to place the values of a mail merge datasource into an array variable?

I'm new to VBA. I apologize for any inconvenience caused by this question.
I'm trying to place the values of the data source into a variable array. These are my codes for reference.
Dim objDoc As Document
Dim FilePath As String
With Dialogs(wdDialogFileOpen)
If .Display Then
If .Name <> "" Then
FilePath = .Name
With ActiveDocument.MailMerge
Dim tempVariable() As String
'To attach selected file to the data source
'**ERROR**
tempVariable = Array(
ActiveDocument.MailMerge.OpenDataSource Name:=FilePath, _
ReadOnly:=True, _
LinkToSource:=True, _
SubType:=WdMergeSubType.wdMergeSubTypeOther)
' ActiveDocument.MailMerge.OpenDataSource Name:=FilePath, _
' ReadOnly:=True, _
' LinkToSource:=True, _
' SubType:=WdMergeSubType.wdMergeSubTypeOther
End With
End If '.Name <> "" Then
Else '.Display Then
MsgBox "No file selected", vbOKOnly, "File not selected"
End If '.Display Then
End With
Unfortunately though, there will be an error that says...
Compile error: Expected: end of statement
What can I do to solve this issue? From what I have assumed, it's a syntax issue.
To what end are you trying to place the data into an array? It's not going to help complete a mailmerge. That said, try:
Sub Capture_Merge_Data()
Dim d As Long, i As Long, j As Long, r As Long
With ActiveDocument.MailMerge.DataSource
d = .DataFields.Count: r = .RecordCount
ReDim DataArray(d, r)
For i = 1 To r
.ActiveRecord = i
For j = 1 To d
DataArray(j - 1, i - 1) = .DataFields(j)
If i * j Mod 1000 = 0 Then DoEvents
Next j
Next i
End With
MsgBox "DataArray populated with " & d & " data fields from " & r & " records."
End Sub

VBA create log file

Hello can you help me please with code in VBA ? I would like create a log file from text in cells ("C2" and "C3 " + date and time ) when I press button "zadat" Thank you
My code for implementation is:
Module 1
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub zadat()
Dim reg, check As String
Dim i, j, done As Integer
reg = Cells(2, 3).Value
check = Cells(4, 3).Value
If check = "True" Then
i = 2
j = 1
done = 0
Do While Sheets("data").Cells(i, j) <> ""
If Sheets("data").Cells(i, j) = reg Then
vytisteno = ZkontrolovatAVytiskoutSoubor()
done = Sheets("data").Cells(i, j + 3)
done = done + 1
Sheets("data").Cells(i, j + 3) = done
Exit Do
End If
i = i + 1
Loop
Else
MsgBox ("Opravit, špatný štítek!!!")
End If
Cells(3, 3) = ""
Cells(3, 3).Select
ActiveWindow.ScrollRow = Cells(1, 1).row
End Sub
Module 2:
Option Explicit
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Public Function PrintThisDoc(formname As Long, FileName As String)
On Error Resume Next
Dim x As Long
x = ShellExecute(formname, "Print", FileName, 0&, 0&, 3)
End Function
Public Function ZkontrolovatAVytiskoutSoubor() As Boolean
Dim printThis
Dim strDir As String
Dim strFile As String
strDir = "W:\Etikety\Štítky\Krabice\Testy"
strFile = Range("C2").Value & ".lbe"
If Not FileExists(strDir & "\" & strFile) Then
MsgBox "soubor neexistuje!"
ZkontrolovatAVytiskoutSoubor = False
Else
printThis = PrintThisDoc(0, strDir & "\" & strFile)
ZkontrolovatAVytiskoutSoubor = True
End If
End Function
Private Function FileExists(fname) As Boolean
'Returns TRUE if the file exists
Dim x As String
x = Dir(fname)
If x <> "" Then FileExists = True _
Else FileExists = False
End Function
If you don't want to use FSO, there is a simple solution using only VBA statements: Open, Print # and Close:
Sub Log2File(Filename As String, Cell1, Cell2)
Dim f As Integer
f = FreeFile
Open Filename For Append Access Write Lock Write As #f
Print #f, Now, Cell1, Cell2
Close #f
End Sub
I've put the filename and the cells refs as arguments of the sub for re-usability purpose. I also use default (local) formatting, but this can be easily changed.
Note that you don't have to check for existence of the file, it will be created if it doesn't exist.
Try this. Below code will create a new log file every time
Public Function LogDetails()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim logFile As Object
Dim logFilePath As String
Dim logFileName As String
'Replace 'TestLog' with your desired file name
logFileName = "TestLog" & ".txt"
myFilePath = "C:\Users\..\Desktop\" & logFileName 'Modify the path here
If fso.FileExists(myFilePath) Then
Set logFile = fso.OpenTextFile(myFilePath, 8)
Else
' create the file instead
Set logFile = fso.CreateTextFile(myFilePath, True)
End If
logFile.WriteLine "[" & Date & " " & Time & "] " & Worksheet("yoursheetnamehere").Cells(2, 3) & " " & Worksheet("yoursheetnamehere").Cells(3, 3)
logFile.Close ' close the file
End Function

Automatically generating handling of issues

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!