Visual Basic for Applications/Redundant Variables List
Summary
[edit | edit source]This very long code module lists an Excel project's redundant variables.
Running the top procedure checks the VBA project of ThisWorkbook, that is, the workbook in which the code is run. It produces both worksheet and user form outputs. The code is self-contained in the one module, but in addition, the user needs to make a user form called ViewVars, with a textbox in it called TextBox1. The details are not too important since the display is adjusted in code to fit the contents. However, the user form's property ShowModal should be set to False, and Multiline set to True. A testing mode of sorts can be had by setting boolean variable bUseWorkSheets in RunVarChecks to True. Be advised however, that this will clear all existing worksheets before writing to sheets one to five. To labor the point, if your intention is to not disturb the contents of project sheets one to five, then be sure that bUseWorkSheets of RunVarChecks is set to False; redundant variables will still be listed in the user form ViewVars after a few seconds of code run.
Points to Note
[edit | edit source]There are some limitations:
- The listing can only work for code that compiles correctly; that is, sensible constructs if not necessarily working code.
- API variable declarations and enumerations of constants are not handled. That is to say, they will not be listed even if they are redundant.
- The module is coded to work with the VBAProject of ThisWorkbook . There is however, an optional parameter to access another workbook object for those who intend to check some other.
- The module works with the usual VBA variable naming methods. This includes the use of public same-names, and fully expressed variable descriptions. It does so by searching for compound similars as well as their simple forms. For example, although rare, the three forms myvar, Module1.myvar, and VBProject.Module1.myvar could all be used in code for the same variable. The use of these forms allows the same variable names to be used in any module heading without conflict.
- Several worksheet listings are made for output results and testing. The user should make sure that sheets 1 to 5 exist, since the code will not create them in this listing. The user might want to restrict or change these in the main procedure if they will conflict with other uses. A separate user form output makes use of procedure AutoLayout.
- The user form styles might not suit everyone, but the colorings and fonts can be changed in two user-sections of the procedure AutoLayout. Bear in mind however, that the chosen font must be monospaced for a neat layout. Apart from this restriction, the layout will handle any regular font size from about 6 to 20 points, as well as the bold and italic variants. That is to say, the code will auto-adjust the userform layout and sizes to produce a useful display.
- Procedures have not been marked as module Private. There is the remote possibility of same-name procedures being encountered when users also make use of other modules in this series. In future I will try to remember to mark them module-private if they look as though they were used elsewhere.
- Interested parties might like to advise of any bugs. Please use only the Discussion page and I will get to them as soon as I can.
Work Method Used
[edit | edit source]General Preparation
[edit | edit source]- The general method is to make a declared variables list then test each variable entry to see if it is used.
- The project string contains all of the code in the project. The string is loaded into a work array line by line, and is passed in variants from process to process.
- Procedure, module, and project name information is also added. Every code line is marked with this information.
- Quotes and comments are removed, since they could contain any text at all, and might confuse the decision process.
- Other confusions arise from continuation lines, so these are all joined up into single long lines prior to interpretation.
- Shared label lines and line numbers can also cause difficulty, so labels are given lines of their own, and line numbers are separated prior to any decision process.
- Blank lines are not needed so they are removed. Because there is a changed line count, the project work array is renumbered.
- Each code line is marked with its residential line ranges. Each line is given the code line range for the procedure and for the module in which it resides. This data is then easily found later.
The Declared Variables
[edit | edit source]- The declared variables list, the array vDec, contains every declared variable in the project.
- It lists all other pertinent data about each variable. The scope of each variable is determined and added. The nominal search line ranges are also added. These are the line ranges suggested at first sight after knowing the scope of the variable. For example, a procedure level declaration would show the procedure line range, and a module-private item the module's line range.
- The variables are marked on vDec when they are found as used. The search sequence is, all of the procedure level variables, then the module private variables, then lastly the public variables. When there are same-name variables with different scopes, this sequence is useful, in that it progressively reduces the required search ranges.
- Every variable is checked for naming ambiguity before deciding which search method to use. Only if there is no names ambiguity can a so-called normal approach be taken; ie; searching the entire nominal line range. Otherwise, the nominal search range needs modified to avoid regions where same-name variables were already found. For example, a module variable search would not look in a procedure where a same-named variable had been both declared and used, but would check anyway if no same-name item were declared there.
- Public and module level variables have to be checked in three names. Variables' full names can include project, module, and variable names, or just module and variable names, in addition to the better known short forms.
- Public variables are handled a bit differently. These variables can exist in each module with the same name. There are two kinds of duplicated names possible for public variables; firstly, there is the kind where there is a public variable with the same name as a variable in any number of procedures, and secondly, there is the kind where the same name is used for a public variable in more than one module heading. In these same-name cases the use of public variables need at least the module and variable name when their use is not in the module where declared.
- Most of the time a public variable's name is entirely unique. That is, there is no other variable in the project with the same name. In this case the use of the variable can be searched throughout the project without restriction.
- If the public variable has no same-names in other module heads, but there are same-names in module or procedure variables, then the whole project must be searched for its use, taking into account line restrictions from modules and procedures where such same-names were already found as used.
- If the public variable has same-name variables in more than one module heading, then the determination of variable use must be handled in two stages;
- The entire project must be searched without restriction using both compound forms of the public variable
- Then search in the module where the public variable is declared, taking account of any procedure restrictions that apply from same-names there.
- After all this, any variables not marked as used can be listed as redundant.
VBA Code Module
[edit | edit source]Updated and Tested 17 Sep 2017
[edit | edit source]Modified changed word aliases to similars (15 Jan 2018).
Modified AutoLayout() to avoid wrap back in form. Label length plus 4 spaces now, not 2. (17 Sep 2017).
Added a note on need for VBA Extensibility 5.3 and tested code - working OK.(31 Dec 2016)
Modified AutoLayout() to reduce control count.(17 Nov 2016).
Modified AutoLayout() for better font choice.(16 Nov 2016).
Added simpler options for fonts in AutoLayout().(16 Nov 2016)
Modified code in dynamic arrays and added test mode switch bUseWorkSheets in RunVarChecks().(15 Nov 2016)
Removed one redundant procedure and corrected TrimStr error.(13 Nov 2016)
Corrected code call to NewPubRange() in MarkPubVarUse(). Parameter lines now whole project.(8 Nov 2016)
Changes made to user form display procedures. (7 Nov 2016)
Option Explicit
Option Base 1
Sub TestVars()
'Be sure to set a reference to Visual Basic for Applications Extensibility 5.3
Dim vWB As Variant
'set reference to a workbook
'in the current workbooks collection
Set vWB = ThisWorkbook
RunVarChecks vWB
End Sub
Sub RunVarChecks(Optional vWB As Variant)
'runs a redundant variable check on a workbook's code project
'If no workbook supplied in vWB defaults to this workbook.
'Exclusions: "Declared", "Type" and "Const" declarations.
'CLEARS ALL WORKSHEETS AND REWRITES TO SHEETS 1 TO 5
'WHEN bUseWorkSheets IS TRUE
Dim sht As Worksheet, vDec As Variant, vX As Variant, vAB As Variant
Dim c As Long, n As Long, UDec2 As Long, sLN As Long, vT As Variant
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
Dim vJ As Variant, vK As Variant, vL As Variant, vM As Variant
Dim vP As Variant, vR As Variant, vS As Variant, vN As Variant
Dim vU As Variant, vV As Variant, vW As Variant, vDisp As Variant
Dim sLS As String, sPN As String, sMN As String, sProc As String
Dim sVScope As String, sP As String, bOneToFind As Boolean
Dim bProcNamed As Boolean, bNotFirst As Boolean, Upper As Long
Dim bUseWorkSheets As Boolean
Dim Uform As UserForm
'==================================================================
bUseWorkSheets = False 'when true, overwrites all worksheets
' and displays test data in sheets 1 to 5,
' else when false, userform output only.
'==================================================================
'decide whether to use parameter wb or this one
If IsMissing(vWB) Then
Set vWB = ThisWorkbook
End If
'clear sheets - clears all sheets
'and unloads open userforms
For Each Uform In VBA.UserForms
Unload Uform
Exit For
Next Uform
If bUseWorkSheets = True Then
For Each sht In ThisWorkbook.Worksheets
sht.Activate
sht.Range("A1:Z65536").ClearContents
Next sht
End If
'PREPARE THE PROJECT ARRAY
sP = LoadProject(vP, vWB) '0 view original source data on sheet 1
'=========================================================================
If bUseWorkSheets = True Then PrintArrayToSheet vP, "Sheet1" 'raw project
'=========================================================================
TrimStr vP, vS '1 remove end spc and tabs-not newlines
JoinBrokenLines vS, vW '2 rejoin broken lines-leaves blank lines
RemoveApostFmQuotes vW, vJ '3
RemoveAllComments vJ, vL '4 remove all comments-leaves blank lines
RemoveBlankLines vL, vK '5 remove all blank lines-reduces line count
RemoveQuotes vK, vM '6 remove all double quotes and their contents
SplitAtColons vM, vV '7 make separate statement lines split at colons
NumbersToRow vV, vU, 6 '8 new line count row 6; originals still in row 1
'DO NOT RENUMBER LINES BEYOND MarkLineRanges()
MarkLineRanges vU, vR '9 mark array with line ranges for search later
'=========================================================================
If bUseWorkSheets = True Then PrintArrayToSheet vR, "Sheet2" 'mod project
'=========================================================================
'get bounds of modified project line array
Lb1 = LBound(vR, 1): Ub1 = UBound(vR, 1)
Lb2 = LBound(vR, 2): Ub2 = UBound(vR, 2)
'redim of declared variables array
ReDim vDec(1 To 12, 0 To 0)
ReDim vDisp(1 To 4, 0 To 0)
'MAKE THE DECLARED VARIABLES ARRAY
'get one line of project array at a time
'if a declaration line, parse it and extract variables
'to build the declared variables array vDec
For c = Lb2 To Ub2
DoEvents
'get one line of data from array
sLN = CStr(vR(1, c)) 'original line number
sPN = vR(3, c) 'project name
sMN = vR(4, c) 'module name
sProc = vR(5, c) 'procedure name
sLS = vR(8, c) 'joined line string
'get declared variables from the line string
If sProc <> "" Then bProcNamed = True Else bProcNamed = False
GetDeclaredVariables sLS, bProcNamed, sVScope, vM
If sVScope <> "" Then
'load declared variables array with dec vars for one line
If UBound(vM) >= 1 Then 'it is a declaration line
'mark the source array string as a declaration line
vR(13, c) = "Declaration"
'transfer found line variables to vDec
For n = LBound(vM) To UBound(vM)
ReDim Preserve vDec(1 To 12, 1 To UBound(vDec, 2) + 1)
UDec2 = UBound(vDec, 2) 'vDec line number
vDec(1, UDec2) = vM(n) 'Declared variable
vDec(2, UDec2) = sPN 'Project name
vDec(3, UDec2) = sMN 'Module name
vDec(4, UDec2) = sProc 'Procedure name
vDec(5, UDec2) = sVScope 'Scope of variable
vDec(6, UDec2) = StartOfRng(vR, sVScope, c) 'Nominal line search start
vDec(7, UDec2) = EndOfRng(vR, sVScope, c) 'Nominal line search end
vDec(8, UDec2) = "" 'Used marking
vDec(9, UDec2) = sLN 'Original line number
vDec(10, UDec2) = "" 'Use checked marker
vDec(11, UDec2) = vR(9, c) 'Module start line number
vDec(12, UDec2) = vR(10, c) 'Module end line number
Next n
End If
End If
Next c
EmptyTheDecLines vR, vT '10 replaces line string with empty string-no change line count
'DISPLAY CONDITIONED PROJECT ARRAY ON WORKSHEET
'=========================================================================
If bUseWorkSheets = True Then PrintArrayToSheet vT, "Sheet3" 'mod project
'=========================================================================
'NOTES
'AT THIS POINT vT CONTAINS THE PROJECT LINES SOURCE TO SEARCH FOR USED VARIABLES.
'vT WILL ALSO BE USED TO SEARCH FOR THE USE OF DECLARED VARIABLES LISTED IN vDec.
'vDec LISTS THE INITIAL LINE NUMBERS RANGE FOR USE-SEARCH, THOUGH THESE ARE LATER MODIFIED.
'The use-search sequence is all procprivate, all modprivate, then all varpublic.
'All declared variables marked as used at one stage need not have their search ranges
'searched again at the next. Eg: Same-name procprivate-used could never be Modprivate-used also.
'Same-name varpublic variables could only apply as used where neither procprivate or modprivate.
'Nominally assigned searched ranges are modified after each stage to narrow the search line ranges
'for the next stage.
'Same-name public variables in each of several module heads are not yet handled.
'MARK THE DECLARED VARIABLES ARRAY WITH USE STATUS
'FIRST - MARK USE OF PROCPRIVATE vDec ITEMS
MarkProcVarUse vDec, vT, vN
vDec = vN
MarkModVarUse vDec, vT, vAB
vDec = vAB
MarkPubVarUse vDec, vT, vX
vDec = vX
'DISPLAY DECLARED VARIABLES ARRAY ON WORKSHEET
'=======================================================================================
If bUseWorkSheets = True Then PrintArrayToSheet vDec, "Sheet4" 'declared variables list
'=======================================================================================
'LOAD REDUNDANT VARIABLES RESULTS ARRAY
For n = LBound(vDec, 2) To UBound(vDec, 2)
' check whether or not marked used
If vDec(8, n) = "" Then
'unused variable so transfer details
If bNotFirst = True Then
'not first data transfer
'so increment array before transfer
Upper = UBound(vDisp, 2) + 1
ReDim Preserve vDisp(1 To 4, 1 To Upper)
Else
'is first data transfer
'so just use first element
ReDim vDisp(1 To 4, 1 To 1)
Upper = UBound(vDisp, 2)
bNotFirst = True
End If
' transfer variable details to display array
vDisp(1, Upper) = vDec(1, n) 'variable name
vDisp(2, Upper) = vDec(4, n) 'procedure name
vDisp(3, Upper) = vDec(3, n) 'module name
vDisp(4, Upper) = vDec(2, n) 'project name
End If
Next n
' report if none found
If UBound(vDisp, 2) = 0 Then
MsgBox "No redundant variables found for display"
Exit Sub
End If
'DISPLAY REDUNDANT VARIABLES RESULTS ON WORKSHEET
'=========================================================================================
If bUseWorkSheets = True Then PrintArrayToSheet vDisp, "Sheet5" 'redundant variables list
'=========================================================================================
'DISPLAY REDUNDANT VARIABLES RESULTS ON USERFORM
AutoLayout vDisp, 1
End Sub
Function LoadProject(vR As Variant, wb As Variant) As String
' Loads local array with parameter workbook's
' whole VBA project string line by line,
' and other details, and returns in array vR.
' Whole project string can be found in LoadProject.
' Needs set reference to Microsoft VBA Extensibility 5.5
'==============================================
' Local String Array sW() Row Details.
' Each line record in one column
'==============================================
'Row 1: Orig proj line number
'Row 2: Orig line string working
'Row 3: Project name
'Row 4: Module name
'Row 5: Procedure name
'Row 6: Reduced proj line number
'Row 7: Temp use for continuation marking
'Row 8: Rejoined versions of lines
'Row 9: Module start number
'Row 10: Module end number
'Row 11: Procedure start number
'Row 12: Procedure end number
'Row 13: n/a
'Row 14: n/a
'==============================================
Dim VBProj As VBIDE.VBProject, VBComp As VBIDE.VBComponent
Dim VBMod As VBIDE.CodeModule, ProcKind As VBIDE.vbext_ProcKind
Dim sMod As String, sProj As String, sLine As String
Dim nLines As Long, n As Long, nC As Long, sW() As String
Dim Ub2 As Long
'redim dynamic array
Erase sW()
ReDim sW(1 To 14, 1 To 1)
'get ref to parameter workbook
Set VBProj = wb.VBProject
'loop through VBComponents collection
For Each VBComp In VBProj.VBComponents
Set VBMod = VBComp.CodeModule
nLines = VBMod.CountOfLines
sProj = sProj & VBMod.Lines(1, nLines) 'project string
sMod = VBMod.Lines(1, nLines) 'module string
If nLines <> 0 Then
With VBMod
For n = 1 To nLines
DoEvents
sLine = Trim(.Lines(n, 1)) 'line string
'Debug.Print sLine
'redim array for each record
ReDim Preserve sW(1 To 14, 1 To nC + n)
Ub2 = UBound(sW, 2)
'load lines of each module into array
sW(1, Ub2) = CStr(Ub2) 'orig proj line number
sW(2, Ub2) = sLine 'raw line string working
sW(3, Ub2) = VBProj.Name 'project name
sW(4, Ub2) = VBMod.Name 'module name
sW(5, Ub2) = .ProcOfLine(n, ProcKind) 'procedure name
sW(6, Ub2) = "" 'reduced proj line number
sW(7, Ub2) = "" 'continuation mark working
sW(8, Ub2) = "" 'long joined-up broken lines
sW(9, Ub2) = "" 'Module start number
sW(10, Ub2) = "" 'Module end number
sW(11, Ub2) = "" 'Procedure start number
sW(12, Ub2) = "" 'Procedure end number
sW(13, Ub2) = "" 'n/a
sW(14, Ub2) = "" 'n/a
Next n
End With
End If
nC = nC + nLines 'increment for next redim
Next VBComp
'Debug.Print sproj
LoadProject = sProj
vR = sW()
Set VBProj = Nothing: Set VBComp = Nothing
Set VBMod = Nothing
End Function
Private Sub TrimStr(vA As Variant, vR As Variant)
'trims leading and lagging spaces and tabs
'from all input array vA code lines
'Returns array in vR
Dim n As Long, c As Long
Dim vW As Variant, str As String
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
vW = vA
'modify the line strings of the array
For c = Lb2 To Ub2
'get the line string
str = vW(2, c)
n = Len(str)
Do 'delete tabs and spaces from left of string
If Left(str, 1) = Chr(32) Or Left(str, 1) = Chr(9) Then
n = Len(str)
str = Right(str, n - 1)
Else
'left is done
Exit Do
End If
Loop
Do 'delete tabs and spaces from right of string
If Right(str, 1) = Chr(32) Or Right(str, 1) = Chr(9) Then
n = Len(str)
str = Left(str, n - 1)
Else
'left is done
Exit Do
End If
Loop
'pass back the mod string
vW(2, c) = str
Next c
'transfers
vR = vW
End Sub
Sub JoinBrokenLines(vP As Variant, vR As Variant)
'Identifies and joins lines with continuation marks
'Whole lines placed into row 8
'Marks old broken bits as newlines.
'Newlines are removed later in RemoveBlankLines().
Dim vA As Variant, vW As Variant, IsContinuation As Boolean
Dim str As String, sAccum As String, n As Long, s As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vP, 1): Ub1 = UBound(vP, 1)
Lb2 = LBound(vP, 2): Ub2 = UBound(vP, 2)
ReDim vW(Lb1 To Ub1, Lb2 To Ub2)
'pass to work variable
vW = vP
'mark all lines that have a continuation chara
For n = LBound(vW, 2) To UBound(vW, 2)
str = vW(2, n) 'line string
IsContinuation = str Like "* _"
If IsContinuation Then vW(7, n) = "continuation"
Next n
'mark the start and end of every continuation group
For n = LBound(vW, 2) To (UBound(vW, 2) - 1)
If n = 1 Then 'for the first line only
If vW(7, n) = "continuation" Then vW(8, n) = "SC"
If vW(7, n) = "continuation" And vW(7, n + 1) <> "continuation" _
Then vW(8, n + 1) = "EC"
Else 'for all lines after the first
'find ends
If vW(7, n) = "continuation" And vW(7, n + 1) <> "continuation" Then
vW(8, n + 1) = "EC"
End If
'find starts
If vW(7, n) = "continuation" And vW(7, n - 1) <> "continuation" Then
'If vw(7, n) <> "continuation" And vw(7, n + 1) = "continuation" Then
vW(8, n) = "SC"
End If
End If
Next n
'make single strings from each continuation group
For n = LBound(vW, 2) To (UBound(vW, 2) - 1)
If vW(8, n) = "SC" Then 'group starts
'join strings to make one string per continuation group
s = n
vA = Split(CStr(vW(2, n)), "_")
str = CStr(vA(0))
sAccum = str
Do Until vW(8, s) = "EC"
s = s + 1
'handle other continued parts
vA = Split(CStr(vW(2, s)), "_")
str = CStr(vA(0))
sAccum = sAccum & str
vW(2, s) = Replace(vW(2, s), vW(2, s), vbNewLine)
Loop
vW(8, n) = sAccum 'place at first line level in array
End If
str = ""
sAccum = ""
s = 0
Next n
'write remaining strings into row 8 for consistency
'all string parsing and other work now uses row 8
For n = Lb2 To Ub2
If vW(8, n) = "" Or vW(8, n) = "SC" Or vW(8, n) = "EC" Then
vW(8, n) = Trim(vW(2, n))
End If
Next n
'transfers
vR = vW
End Sub
Sub RemoveApostFmQuotes(vB As Variant, vR As Variant)
'returns array vB as vR with apostrophies removed
'from between sets of double quotes,
'Remainder of quote and double quotes themselves left intact.
'for example s = "Dim eyes (Bob's)" becomes s = "Dim eyes (Bobs)"
Dim str As String, str1 As String, vA As Variant, c As Long
Dim n As Long, m As Long, bUnpaired As Boolean, r As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vB, 1): Ub1 = UBound(vB, 1)
Lb2 = LBound(vB, 2): Ub2 = UBound(vB, 2)
ReDim vR(Lb1 To Ub1, Lb2 To Ub2)
'set up loop to get one line at a time
For c = Lb2 To Ub2
str = vB(8, c)
'split string at double quotes
If str <> "" Then
vA = Split(str, """")
Else
'empty string
str1 = str
GoTo Transfers
End If
'recombine the splits
m = UBound(vA) - LBound(vA)
'as long as even num of quote pairs
If m Mod 2 = 0 Then
For n = LBound(vA) To UBound(vA)
If n Mod 2 = 0 Then 'even elements
str1 = str1 & vA(n)
Else
'odd elements
'apostrophies removed
str1 = str1 & Replace(vA(n), "'", "")
End If
Next n
Else
'unpaired double quotes detected
bUnpaired = True
End If
Transfers: 'transfer one row only
For r = Lb1 To Ub1
vR(r, c) = vB(r, c)
Next r
'if all pairs matched
If bUnpaired = False Then
vR(8, c) = str1
Else
'exit loop with str
End If
str1 = "" 'reset accumulator
bUnpaired = False
Next c
End Sub
Sub RemoveAllComments(vA As Variant, vR As Variant)
'Removes all comments from vA row 8 line strings
'Includes comments front, middle and end so
'apostrophed text in double quotes would result
'in a false line split if not first removed.
Dim bAny As Boolean, bStart As Boolean, bEnd As Boolean
Dim n As Long, m As Long, c As Long, r As Long
Dim bincluded As Boolean, l As Long, str As String
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vR(Lb1 To Ub1, 0 To 0)
For c = Lb2 To Ub2
str = vA(8, c)
'detect any instance of a comment mark
bAny = str Like "*'*"
If Not bAny Then
'go for row INCLUSION action
'with original str
bincluded = True
GoTo Transfers
Else
'comment front, 'middle, or 'end
End If
'find whether or not has comment at front
bStart = str Like "'*"
If bStart Then
'go for row EXCLUSION action
'do not include row at all
bincluded = False
GoTo Transfers
Else
'might still have comment at end
End If
'find whether or not has comment at end
bEnd = str Like "* '*"
If bEnd Then
'remove comment at end
l = Len(str)
For n = 1 To l
If Mid(str, n, 2) = " '" Then
str = Trim(Left(str, n - 1))
'go for row INCLUSION action
'with modified str
bincluded = True
GoTo Transfers
End If
Next n
End If
'decide on how to do the default thing
Transfers:
If bincluded = True Then
'include the current row
m = m + 1
ReDim Preserve vR(Lb1 To Ub1, 1 To m)
For r = Lb1 To Ub1
vR(r, m) = vA(r, c)
Next r
vR(8, m) = str
Else
'do not include the current row
End If
Next c
End Sub
Sub RemoveBlankLines(vA As Variant, vR As Variant)
'removes all blank lines from proj array vA
'and returns with modified array in vR
'Changes line count
Dim vM As Variant, bNotFirst As Boolean
Dim c As Long, r As Long, Upper As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vM(Lb1 To Ub1, 1 To 1)
For c = Lb2 To Ub2
If vA(8, c) <> "" And vA(8, c) <> vbNewLine Then
If bNotFirst = True Then
'not first data transfer
'so increment array before transfer
Upper = UBound(vM, 2) + 1
ReDim Preserve vM(Lb1 To Ub1, 1 To Upper)
Else
'is first data transfer
'so just use first element
Upper = UBound(vM, 2)
bNotFirst = True
End If
'transfer data
For r = Lb1 To Ub1
vM(r, Upper) = vA(r, c)
Next r
End If
Next c
vR = vM
End Sub
Sub RemoveQuotes(vB As Variant, vR As Variant)
'returns array vB as vR with all text between pairs
'of double quotes removed, and double quotes themselves
'for example s = "Dim eyes" becomes s =
'A failed quotes pairing returns original string.
Dim str As String, str1 As String, vA As Variant, c As Long
Dim n As Long, m As Long, bUnpaired As Boolean, r As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vB, 1): Ub1 = UBound(vB, 1)
Lb2 = LBound(vB, 2): Ub2 = UBound(vB, 2)
ReDim vR(Lb1 To Ub1, Lb2 To Ub2)
'set up loop to get one line at a time
For c = Lb2 To Ub2
str = vB(8, c)
'split string at double quotes
If str <> "" Then
vA = Split(str, """")
Else
'empty string
str1 = str
GoTo Transfers
End If
'overwrite odd elements to be empty strings
m = UBound(vA) - LBound(vA)
'as long as even num of quote pairs
If m Mod 2 = 0 Then
For n = LBound(vA) To UBound(vA)
'accum even elements
If n Mod 2 = 0 Then
str1 = str1 & vA(n)
End If
Next n
Else
'unpaired double quotes detected
bUnpaired = True
End If
Transfers: 'transfer one row only
For r = Lb1 To Ub1
vR(r, c) = vB(r, c)
Next r
'if all pairs matched
If bUnpaired = False Then
vR(8, c) = str1
Else
'exit loop with str
End If
str1 = "" 'reset accumulator
bUnpaired = False
Next c
End Sub
Sub SplitAtColons(vA As Variant, vR As Variant)
'Because statements and other lines can be placed
'in line and separated by colons, they must be split.
'Splits such into separate lines and increases line count,
'Input array in vA and returns in vR.
'Note: The space after colon is distinct from named arguments
'that have no space after the colon.
Dim vF As Variant, vW As Variant
Dim n As Long, sLine As String, bNotFirst As Boolean
Dim Elem As Variant, m As Long, Upper As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vW(Lb1 To Ub1, Lb2 To Ub2)
ReDim vR(Lb1 To Ub1, 1 To 1)
'pass to work variable
vW = vA
For n = Lb2 To Ub2 'for each line existing
'get line string
sLine = Trim(vW(8, n))
'decide if has colons
'do the split
vF = Split(sLine, ": ")
'does it contain colons?
If UBound(vF) >= 1 Then 'there were non-arg colons
'make a new line in return array for each elem
For Each Elem In vF
Elem = Trim(CStr(Elem))
If Elem <> "" Then
If bNotFirst = True Then
'not first data transfer
'so increment array before transfer
Upper = UBound(vR, 2) + 1
ReDim Preserve vR(Lb1 To Ub1, 1 To Upper)
Else
'is first data transfer
'so just use first element
Upper = UBound(vR, 2)
bNotFirst = True
End If
'transfer line of vW to vR
For m = 1 To 8
vR(m, Upper) = vW(m, n)
Next m
vR(8, Upper) = Elem 'overwrite line string
End If
Next Elem
Else
'no colons - redim array and normal line transfer
If bNotFirst = True Then
'not first data transfer
'so increment array before transfer
Upper = UBound(vR, 2) + 1
ReDim Preserve vR(Lb1 To Ub1, 1 To Upper)
Else
'is first data transfer
'so just use first element
Upper = UBound(vR, 2)
bNotFirst = True
End If
ReDim Preserve vR(Lb1 To Ub1, 1 To Upper)
'transfer line of vW to vR
For m = Lb1 To Ub1
vR(m, Upper) = vW(m, n)
Next m
End If
Next n
End Sub
Sub NumbersToRow(vA As Variant, vR As Variant, Optional nRow As Long = 6)
'adds renumbering of current array lines to row 6.
'and returns vA array in vR. Original numbers still in row 1.
'Optional row number defaults to 6
Dim n As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vR(Lb1 To Ub1, Lb2 To Ub2)
For n = Lb2 To Ub2
vA(nRow, n) = n
Next n
vR = vA
End Sub
Sub MarkLineRanges(vA As Variant, vR As Variant)
'Input array in vA, returned in vR with markings.
'Adds any module and procedure line ranges
'that may apply, for every line of vA. These figures
'will be used for the nominal search line ranges.
Dim nS As Long, sS As String, vW As Variant, n As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vR(Lb1 To Ub1, Lb2 To Ub2)
vW = vA
'MODULE START RANGE
'get the start point values in place
sS = Trim(vW(4, 1)) 'get first module name
nS = CLng(Trim(vW(6, 1))) 'get line number for first module entry
vW(9, Lb2) = nS
For n = Lb2 To Ub2 - 1
'If vW(5, n) = "" Then 'it is a module entry
'count same items
If vW(4, n) = vW(4, n + 1) Then
'still same module name
'so mark start value same
vW(9, n + 1) = nS
Else
'n+1 when not same
sS = vW(4, n + 1)
vW(9, n) = nS
nS = vW(6, n + 1)
vW(9, n + 1) = nS
End If
Next n
'MODULE END RANGE
sS = Trim(vW(4, Ub2)) 'get last module name
nS = CLng(Trim(vW(6, Ub2))) 'get line number for first module entry
vW(10, Ub2) = nS
For n = Ub2 To (Lb2 + 1) Step -1
'If vW(5, n) = "" Then 'it is a module entry
'count same items
If vW(4, n) = vW(4, n - 1) Then
'still same module name
'so mark start value same
vW(10, n - 1) = nS
Else
'n+1 when not same
sS = vW(4, n - 1)
vW(10, n) = nS
nS = vW(6, n - 1)
vW(10, n - 1) = nS
End If
Next n
'PROCEDURE START RANGE
'get the start point values in place
sS = Trim(vW(5, 1)) 'get first procedure name
nS = CLng(Trim(vW(6, 1))) 'get line number proc entry
vW(11, Lb2) = nS
For n = Lb2 To Ub2 - 1
'If vW(5, n) = "" Then 'it is a module entry
'count same items
If vW(5, n) = vW(5, n + 1) Then
'still same module name
'so mark start value same
vW(11, n + 1) = nS
Else
'n+1 when not same
sS = vW(5, n + 1)
vW(11, n) = nS
nS = vW(6, n + 1)
vW(11, n + 1) = nS
End If
Next n
'PROCEDURE END RANGE
sS = Trim(vW(5, Ub2)) 'get last proc name
nS = CLng(Trim(vW(6, Ub2))) 'get line number proc entry
vW(12, Ub2) = nS
For n = Ub2 To (Lb2 + 1) Step -1
'If vW(5, n) = "" Then 'it is a module entry
'count same items
If vW(5, n) = vW(5, n - 1) Then
'still same module name
'so mark start value same
vW(12, n - 1) = nS
Else
'n+1 when not same
sS = vW(5, n - 1)
vW(12, n) = nS
nS = vW(6, n - 1)
vW(12, n - 1) = nS
End If
Next n
'ADD PUBLIC VARIABLE LINE RANGES
'public variable line ranges need not be marked
'since the whole project line range applies
'transfers
vR = vW
End Sub
Sub GetDeclaredVariables(sLine As String, bProcName As Boolean, sScope As String, vRet As Variant)
'Returns an array of declared variables in line string sLine.
'This is used to build the declared variables array (vDec) in RunVarChecks().
'bProcName input is true if sLine project record lists a procedure name, else false.
'sScope outputs scope of line declarations returned in vRet.
'sScope values are "PROCPRIVATE", "DECLARED", "MODPRIVATE", or "VARPUBLIC"
'=========================================================================
'sScope RETURNS:
'"PROCPRIVATE"; returned if declaration is private to a procedure
'"MODPRIVATE"; returned if declaration is private to a module
'"VARPUBLIC"; returned if declaration is public
'"DECLARED"; returned if declared with keyword "Declared" in heading
'=========================================================================
Dim IsDim As Boolean, nL As Long, vF As Variant
Dim Elem As Variant, vS As Variant, vT As Variant
Dim bPrivate As Boolean, bPublic As Boolean, bStatic As Boolean
Dim bPrivPubStat As Boolean, bDeclare As Boolean, bType As Boolean
Dim bSub As Boolean, bFunc As Boolean, bConst As Boolean
Dim n As Long, Upper As Long, bNotFirst As Boolean
' '----------------------------------------------------------------------------
' Handle exclusions: lines that contain any of the declaration keywords;
' "Declare", "Const", and "Type"
' '----------------------------------------------------------------------------
bDeclare = sLine Like "* Declare *" Or sLine Like "Declare *"
bConst = sLine Like "* Const *" Or sLine Like "Const *"
bType = sLine Like "* Type *" Or sLine Like "Type *"
If bDeclare Or bConst Or bType Then
GoTo DefaultTransfer
End If
'----------------------------------------------------------------------------
' Then, check declarations that were made with the "Dim" statement,
' at private module and at procedure level.
'----------------------------------------------------------------------------
'sLine = "Dim IsDim As Boolean, nL As Long, vF(1 to4,4 to 6,7 to 10) As Variant"
sLine = Trim(sLine)
ReDim vT(0 To 0)
IsDim = sLine Like "Dim *"
'could be proc or module level
If IsDim Then
nL = Len(sLine)
sLine = Right(sLine, nL - 4)
'do the first split
sLine = RemoveVarArgs(sLine)
vF = Split(sLine, ",")
'do the second split
For Each Elem In vF
Elem = Trim(CStr(Elem))
If Elem <> "" Then
vS = Split(Elem, " ")
'Optional might still preceed var name
For n = LBound(vS) To UBound(vS)
If vS(n) <> "Optional" Then
'redim the array
If bNotFirst = True Then
'not first data transfer
'so increment array before transfer
Upper = UBound(vT) + 1
ReDim Preserve vT(LBound(vT) To Upper)
Else
'is first data transfer
'so just use first element
ReDim vT(1 To 1)
Upper = UBound(vT)
bNotFirst = True
End If
vT(Upper) = vS(n)
Exit For
End If
Next n
End If
Next Elem
'return results
If UBound(vT, 1) >= 1 Then
If bProcName = True Then
Transfer1: sScope = "PROCPRIVATE"
Else
sScope = "MODPRIVATE"
End If
vRet = vT
Exit Sub 'Function
End If
Else: 'not a dim item so...
GoTo CheckProcLines
End If
CheckProcLines:
'---------------------------------------------------------------------------------
' Check declarations that were made in public and private procedure definitions.
' Procedure definitions made in the module heading with declare are excluded.
'---------------------------------------------------------------------------------
bSub = sLine Like "*Sub *(*[A-z]*)*"
bFunc = sLine Like "*Function *(*[A-z]*)*"
If bSub Or bFunc Then
'obtain contents of first set round brackets
sLine = GetProcArgs(sLine)
'obtain vars without args
sLine = RemoveVarArgs(sLine)
'first split
vF = Split(sLine, ",")
For Each Elem In vF
Elem = Trim(CStr(Elem))
If Elem <> "" Then
'second split
vS = Split(Elem, " ")
'any of Optional, ByVal, ByRef, or ParamArray might preceed var name
For n = LBound(vS) To UBound(vS)
If vS(n) <> "Declare" And vS(n) <> "Optional" And vS(n) <> "ByVal" And _
vS(n) <> "ByRef" And vS(n) <> "ParamArray" Then
'redim the array
If bNotFirst = True Then
'not first data transfer
'so increment array before transfer
Upper = UBound(vT) + 1
ReDim Preserve vT(LBound(vT) To Upper)
Else
'is first data transfer
'so just use first element
ReDim vT(1 To 1)
Upper = UBound(vT)
bNotFirst = True
End If
vT(Upper) = vS(n)
Exit For
End If
Next n
End If
Next Elem
'return results if any found in section
If UBound(vT) >= 1 Then
If bProcName = True Then
Transfers2: sScope = "PROCPRIVATE"
Else
'exits with empty sScope
sScope = ""
End If
vRet = vT
Exit Sub
End If
Else 'not a dec proc line so...
GoTo OtherVarDecs
End If
OtherVarDecs:
'--------------------------------------------------------------------------------------------
' Check variable declarations at module level outside of any procedures that
' use the private, public, or static keywords. Dim decs were considered in first section.
'--------------------------------------------------------------------------------------------
'test line for keywords
bSub = sLine Like "* Sub *"
bFunc = sLine Like "* Function *"
bPrivate = sLine Like "Private *"
bPublic = sLine Like "Public *"
bStatic = sLine Like "Static *"
If bPrivate Or bPublic Or bStatic Then bPrivPubStat = True
'exclude module procs but include mod vars
If bConst Then GoTo DefaultTransfer
If bPrivPubStat And Not bSub And Not bFunc Then
'remove variable args brackets altogether
sLine = RemoveVarArgs(sLine)
'first split
vF = Split(sLine, ",")
For Each Elem In vF
Elem = Trim(CStr(Elem))
If Elem <> "" Then
vS = Split(Elem, " ")
'any of private, public, or withEvents could preceed var name
For n = LBound(vS) To UBound(vS)
If vS(n) <> "Private" And vS(n) <> "Public" And _
vS(n) <> "WithEvents" Then
'redim the array
If bNotFirst = True Then
'not first data transfer
'so increment array before transfer
Upper = UBound(vT) + 1
ReDim Preserve vT(LBound(vT) To Upper)
Else
'is first data transfer
'so just use first element
ReDim vT(1 To 1)
Upper = UBound(vT)
bNotFirst = True
End If
vT(Upper) = vS(n)
Exit For
End If
Next n
End If
Next Elem
'return array and results
If UBound(vT) >= 1 Then
If bPrivate Then
Transfers3: sScope = "MODPRIVATE"
ElseIf bPublic Then
sScope = "VARPUBLIC"
End If
vRet = vT
Exit Sub
End If
Else 'not a mod private ,public, etc, so...
GoTo DefaultTransfer
End If
DefaultTransfer:
'no declarations in this line
'so hand back empty vT(0 to 0)
sScope = ""
vRet = vT
End Sub
Function GetProcArgs(str As String) As String
'Extracts and returns content of FIRST set of round brackets
'This releases the procedure arguments bundle,
'Brackets of arguments themselves removed in RemoveVarArgs.
Dim LeadPos As Long, LagPos As Long
Dim LeadCount As Long, LagCount As Long, Length As Long
Dim n As Long, sTemp1 As String, m As Long
Length = Len(Trim(str))
For n = 1 To Length
If Mid(str, n, 1) = "(" Then
LeadCount = LeadCount + 1
LeadPos = n
For m = LeadPos + 1 To Length
If Mid(str, m, 1) = "(" Then
LeadCount = LeadCount + 1
End If
If Mid(str, m, 1) = ")" Then
LagCount = LagCount + 1
End If
If LeadCount = LagCount And LeadCount <> 0 Then
LagPos = m
'extract the string from between Leadcount and LagCount, without brackets
sTemp1 = Mid(str, LeadPos + 1, LagPos - LeadPos - 1)
GetProcArgs = sTemp1 'return
Exit Function
End If
Next m
End If
Next n
End Function
Function RemoveVarArgs(ByVal str As String) As String
'Removes ALL round brackets and their content from str input.
'Returns modified string in function name RemoveVarArgs.
'============================================================
'Notes: REMOVES ALL ROUND BRACKETS AND THEIR CONTENTS
'the string: dim Arr(1 to 3, 3 to (6+3)), Var() as String
'becomes: dim Arr, Var as String
'============================================================
Dim bIsAMatch As Boolean, LeadPos As Long, LagPos As Long
Dim LeadCount As Long, LagCount As Long, Length As Long
Dim n As Long, sTemp1 As String, sTemp2 As String, m As Long
Do
DoEvents
bIsAMatch = str Like "*(*)*"
If Not bIsAMatch Then Exit Do
Length = Len(Trim(str))
For n = 1 To Length
If Mid(str, n, 1) = "(" Then
LeadCount = LeadCount + 1
LeadPos = n
For m = LeadPos + 1 To Length
If Mid(str, m, 1) = "(" Then
LeadCount = LeadCount + 1
End If
If Mid(str, m, 1) = ")" Then
LagCount = LagCount + 1
End If
If LeadCount = LagCount And LeadCount <> 0 Then
LagPos = m
'remove current brackets and all between them
sTemp1 = Mid(str, LeadPos, LagPos - LeadPos + 1)
sTemp2 = Replace(str, sTemp1, "", 1)
str = sTemp2
Exit For
End If
Next m
End If
bIsAMatch = str Like "*(*)*"
If Not bIsAMatch Then Exit For
Next n
LeadCount = 0
LagCount = 0
LeadPos = 0
LagPos = 0
Loop
RemoveVarArgs = str 'return
End Function
Sub EmptyTheDecLines(vA As Variant, vR As Variant)
'Input array in vA, returned in vR modified.
'Overwrites row 8 line string with empty string
'if line is marked in proj array as a declaration line,
'but leaves other parts of that record intact.
Dim c As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vR(Lb1 To Ub1, Lb2 To Ub2)
vR = vA
For c = Lb2 To Ub2
If vA(13, c) = "Declaration" Then
vR(8, c) = ""
End If
Next c
End Sub
Function MarkProcVarUse(vA As Variant, vT As Variant, vR As Variant) As Boolean
'Updates vDec declared variables array with use data for
'variables declared in procedures.
'Takes vDec in vA and returns modified with markup in vR.
'vT is the project code lines array.
Dim sD As String, sL As String, n As Long, m As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of vDec input as vA
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vR(Lb1 To Ub1, Lb2 To Ub2)
vR = vA
'step through declared variables array names
For n = LBound(vR, 2) To UBound(vR, 2)
'get one declared variable at a time...
sD = vR(1, n)
'for its associated nominal search lines...
For m = vR(6, n) To vR(7, n)
'and if not a declaration line...
If vT(8, m) <> "" And vR(5, n) = "PROCPRIVATE" Then
'get project line to check...
sL = vT(8, m)
'check project line against all use patterns
If PatternCheck(sL, sD) Then
'mark declared var line as used
vR(8, n) = "Used"
Exit For
Else
End If
End If
Next m
Next n
End Function
Function MarkModVarUse(vA As Variant, vT As Variant, vR As Variant) As Boolean
'Updates vDec declared variables array with use data
'for variables declared at module-private level.
'Takes vDec in vA and returns modified with markup in vR.
'vT is the project code lines array.
Dim sA1 As String, sA2 As String, sL As String, q As Long
Dim sD As String, n As Long, m As Long, vRet As Variant
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of vDec input as vA
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vR(Lb1 To Ub1, Lb2 To Ub2)
vR = vA
'CHECK MODPRIVATE ALIAS NAMES IN WHOLE MODULES
'without any line restriction
'no harm in doing all modprivate this way first
'step through declared variables array
For n = Lb2 To Ub2
'If item is modprivate...
If vR(5, n) = "MODPRIVATE" Then
'get both alias names for one variable...
sA1 = vR(3, n) & "." & vR(1, n) 'mod.var
sA2 = vR(2, n) & "." & vR(3, n) & "." & vR(1, n) 'proj.mod.var
'for whole module line set...
For m = vR(11, n) To vR(12, n)
'get proj line
sL = vT(8, m)
'check line against vR use patterns...
If PatternCheck(sL, sA1) Then
'mark declared vRriable as used
vR(8, n) = "Used"
Exit For
End If
If PatternCheck(sL, sA2) Then
'mark declared vRriable as used
vR(8, n) = "Used"
Exit For
End If
Next m
Else
'action for not modprivate
End If
Next n
'then...
'CHECK MODPRIVATE SHORT NAMES AGAINST WHOLE MODULES
'excluding proc lines using vars with same names
'step through declared variables array
For n = Lb2 To Ub2
'if not already found to be used in above section...
If vR(5, n) = "MODPRIVATE" And vR(8, n) <> "Used" Then
'get its usual short form var name
sD = vR(1, n)
'get a modified search range to exclude proc same-names
NewRange vR, n, CLng(vR(6, n)), CLng(vR(7, n)), vRet
'search for pattern match in restricted range
For q = LBound(vRet) To UBound(vRet)
'if not a declaration line, and n is modprivate, and a permitted search line
If vT(8, q) <> "" And vR(5, n) = "MODPRIVATE" And vRet(q) = "" Then
'search in project array with line q
sL = vT(8, q)
If PatternCheck(sL, sD) Then
vR(8, n) = "Used"
Exit For
End If
End If
Next q
End If
Next n
End Function
Function MarkPubVarUse(vA As Variant, vT As Variant, vR As Variant) As Boolean
'Updates vDec declared variables array with use data
'for variables declared as public in module heads.
'Takes vDec in vA and returns modified with markup in vR.
'vT is the project code lines array.
Dim sA1 As String, sA2 As String, sL As String, q As Long
Dim sD As String, n As Long, m As Long, vRet As Variant
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of vDec input as vA
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vR(Lb1 To Ub1, Lb2 To Ub2)
vR = vA
GeneralChecks:
'CHECK VARPUBLIC ALIAS NAMES IN WHOLE PROJECT
'DO THIS IN EVERY CASE
'without any line restrictions
'do this for all varpublic items first
'step through declared variables array
For n = Lb2 To Ub2
'If item is varpublic...
If vR(5, n) = "VARPUBLIC" And vR(8, n) <> "Used" Then
'get both alias names for one variable...
sA1 = vR(3, n) & "." & vR(1, n) 'mod.vRr
sA2 = vR(2, n) & "." & vR(3, n) & "." & vR(1, n) 'proj.mod.vRr
'for whole project line set...
For m = LBound(vT, 2) To UBound(vT, 2)
'get proj line
sL = vT(8, m)
'check line against vR use patterns...
If PatternCheck(sL, sA1) Then
'mark declared vRriable as used
vR(8, n) = "Used"
Exit For
End If
If PatternCheck(sL, sA2) Then
'mark declared vRriable as used
vR(8, n) = "Used"
Exit For
End If
Next m
End If
Next n
'then...
'CHECK VARPUBLIC SHORT NAME USE DEPENDING ON ANY NAME DUPLICATION
'step through declared variables array
For n = Lb2 To Ub2
'if not already found to be used in above section...
If vR(5, n) = "VARPUBLIC" And vR(8, n) <> "Used" Then
'get its usual var name
sD = vR(1, n)
' Ambiguous returns true if other pub vars use same name
If Ambiguous(vR, n) Then
Ambiguous: 'CHECK VARPUBLIC SHORT NAME USE IN MODULES ONLY -similars already checked fully
'get a modified search range to exclude proc same-names
NewRange vR, n, CLng(vR(11, n)), CLng(vR(12, n)), vRet
'run through newly permitted module search lines
For q = LBound(vRet) To UBound(vRet)
'if not a declaration line, and n is modprivate, and a permitted search line
If vT(8, q) <> "" And vR(5, n) = "VARPUBLIC" And vRet(q) = "" Then
'search in project array with line q
sL = vT(8, q)
If PatternCheck(sL, sD) Then
vR(8, n) = "Used"
Exit For
End If
End If
Next q
Else
Unambiguous: 'resolve use when there is no ambiguous variable duplication anywhere
'CHECK VARPUBLIC SHORT NAME USE IN WHOLE PROJECT
'get a modified search range to exclude proc and module same-names
NewPubRange vR, n, LBound(vT, 2), UBound(vT, 2), vRet
'run through newly permitted project search lines
For q = LBound(vRet) To UBound(vRet)
'if not a declaration line, and n is varpublic, and a permitted search line
If vT(8, q) <> "" And vR(5, n) = "VARPUBLIC" And vRet(q) = "" Then
'search in project array with line q
sL = vT(8, q)
If PatternCheck(sL, sD) Then
vR(8, n) = "Used"
Else
End If
End If
Next q
End If
End If
Next n
End Function
Function Ambiguous(vA As Variant, n As Long) As Boolean
'Returns function name as true if the public variable
'in line number n of vDec has duplicated use of its
'name elsewhere in vDec declared variables listing,
'by another public variable, else it is false.
'Public variables CAN exist with same names.
Dim m As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of vDec input as vA
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
'step through vDec as vA checking item n against all others
For m = Lb2 To Ub2
'if rows different,names same,projects same,and both varpublic...
If m <> n And vA(1, n) = vA(1, m) And vA(2, n) = vA(2, m) And _
vA(5, n) = "VARPUBLIC" And vA(5, m) = "VARPUBLIC" Then
'there is duplication for public variable name in row n
Ambiguous = True
Exit Function
End If
Next m
End Function
Function NewPubRange(vA As Variant, n As Long, nS As Long, nE As Long, vR As Variant) As Boolean
'Input is vDec array in vA. Returns vR array with search restriction markings.
'Used for public variable use search in MarkPubVarUsewhen there is no ambiguous naming at all.
'The nominal search range is input as nS and nE,and this line range will be marked to search or not.
'Input n is vDec line number for the public variable name that needs a search data range returned.
'vR array elements are marked "X" to avoid that line and "" to search it in the project array.
Dim nSS As Long, nSE As Long
Dim strD As String, m As Long, p As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of vDec input as vA
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
'set size of return array equal to number of nominal search lines
'that is for this proc the entire project range
ReDim vR(nS To nE)
'get usual var name
strD = vA(1, n)
'search for variable name in declared variables array
For m = Lb2 To Ub2
'if not same rows, and var name same, and project same, and was used...
'then its proc or module search lines all need excluded from project search
If n <> m And strD = vA(1, m) And vA(2, n) = vA(2, m) And vA(8, m) = "Used" Then
'get item's range to exclude
nSS = vA(6, m) 'start nominal range for samename item
nSE = vA(7, m) 'end nominal range for samename item
'mark vR with exclusion marks
For p = nSS To nSE
vR(p) = "X" 'exclude this line
Next p
End If
Next m
NewPubRange = True
End Function
Function NewRange(vA As Variant, n As Long, nS As Long, nE As Long, vR As Variant) As Boolean
'Used for both public and module variable name search. For short form of name.
'Makes an array that is used to restrict the used-var search range.
'nS and nE are start and end nominal search line numbers.
'Input is vDec in vA, n is vDec line number for variable under test, vR is return array.
'returns array vR marked "X" for exclusion of search where a procedure has a
'same-name variable to that of line n in vDec. Restricts the nominal search range.
Dim nSS As Long, nSE As Long
Dim strD As String, m As Long, p As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of vDec input as vA
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
'set size of return array equal to number of nominal search lines
ReDim vR(nS To nE)
'get usual var name
strD = vA(1, n)
'search for variable name in declared variables array
For m = Lb2 To Ub2
'if not same rows, and var name same, and project same, and module same, and has a procedure name,
'and was used...then its proc search lines all need excluded from module search
If n <> m And strD = vA(1, m) And vA(2, n) = vA(2, m) And vA(3, n) = vA(3, m) And _
vA(4, m) <> "" And vA(8, m) = "Used" Then 'in a proc
'get item's range to exclude
nSS = vA(6, m) 'start nominal range for samename item
nSE = vA(7, m) 'end nominal range samename item
'mark vR with exclusion marks
For p = nSS To nSE
vR(p) = "X" 'exclude this line
Next p
End If
Next m
NewRange = True
End Function
Function StartOfRng(vA As Variant, sScp As String, n As Long) As Long
'Returns line number in function name that starts nominal search range.
'Information already on the project array.
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
'get ranges using new line numbers in row 6
Select Case sScp
Case "PROCPRIVATE"
StartOfRng = vA(11, n)
Case "MODPRIVATE"
StartOfRng = vA(9, n)
Case "VARPUBLIC"
StartOfRng = LBound(vA, 2)
Case "DECLARED"
'StartOfRng = vA(9, n)
Case Else
MsgBox "Dec var scope not found"
End Select
End Function
Function EndOfRng(vA As Variant, sScp As String, n As Long) As Long
'Returns line number in function name for end of used search
'Information already on the project array
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
'get ranges using new line numbers in row 6
Select Case sScp
Case "PROCPRIVATE"
EndOfRng = vA(12, n)
Case "MODPRIVATE"
EndOfRng = vA(10, n)
Case "VARPUBLIC"
EndOfRng = UBound(vA, 2)
Case "DECLARED"
'EndOfRng = vA(10, n)
Case Else
MsgBox "Dec var scope not found"
End Select
End Function
Sub PrintArrayToSheet(vA As Variant, sSht As String)
'Used at various points in project to display test info
'Writes input array vA to sSht with top left at cells(1,1)
'Sheet writing assumes lower bound of array is 1
'Makes use of Transpose2DArr()
Dim sht As Worksheet, r As Long, c As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long, vRet As Variant
Transpose2DArr vA, vRet
'get bounds of project array
Lb1 = LBound(vRet, 1): Ub1 = UBound(vRet, 1)
Lb2 = LBound(vRet, 2): Ub2 = UBound(vRet, 2)
If Lb1 <> 0 And Lb2 <> 0 And Ub1 <> 0 And Ub2 <> 0 Then
Set sht = ThisWorkbook.Worksheets(sSht)
sht.Activate
For r = Lb1 To Ub1
For c = Lb2 To Ub2
sht.Cells(r, c) = vRet(r, c)
Next c
Next r
sht.Cells(1, 1).Select
Else
'MsgBox "No redundant variables found."
End If
End Sub
Function Transpose2DArr(ByRef vA As Variant, Optional ByRef vR As Variant) As Boolean
' Used in both user form and sheet output displays.
' Transposes a 2D array of numbers or strings.
' Returns the transposed vA array as vR with vA intact.
Dim loR As Long, hiR As Long, loC As Long, hiC As Long
Dim r As Long, c As Long
'find bounds of vA data input array
loR = LBound(vA, 1): hiR = UBound(vA, 1)
loC = LBound(vA, 2): hiC = UBound(vA, 2)
'set vR dimensions transposed
'If Not IsMissing(vR) Then
If IsArray(vR) Then Erase vR
ReDim vR(loC To hiC, loR To hiR)
'End If
'transfer data
For r = loR To hiR
For c = loC To hiC
'transpose vA into vR
vR(c, r) = vA(r, c)
Next c
Next r
Transfers:
'return success for function
Transpose2DArr = True
End Function
Sub StrToNextRow(sIn As String, sSht As String, Optional nCol As Long = 1)
'Writes to next free row of nCol.
'Optional parameter nCol defaults to unity.
'sIn: String input to display, sSht: Worksheet string name to write to.
Dim sht As Worksheet, nRow As Long
Set sht = ThisWorkbook.Worksheets(sSht)
sht.Activate
nRow = Cells(Rows.Count, nCol).End(xlUp).Row + 1
sht.Cells(nRow, nCol).Activate
ActiveCell.Value = sIn
End Sub
Function PatternCheck(sLine As String, sDec As String) As Boolean
'Used to determine whether or not a declared variable is used.
'Returns PatternCheck as true if sDec was used
'in sLine, else false. sDec is the declared variable
'and sLine is the previously modified code line. Modifications
'removed quotes and comments that can cause error.
'Checks against a set of common use patterns.
'Dim sLine As String, sDec As String
Dim bIsAMatch As Boolean, n As Long
Dim Lb2 As Long, Ub2 As Long
For n = Lb2 To Ub2
'if parameter found in format of pattern returns true - else false
'IN ORDER OF FREQUENCY OF USE;
'PATTERNS FOR FINDING WHETHER OR NOT A VARIABLE IS USED IN A LINE STRING
'A = Var + 1 or A = b + Var + c
bIsAMatch = sLine Like "* " & sDec & " *" 'spaced both sides
If bIsAMatch Then Exit For
'Var = 1
bIsAMatch = sLine Like sDec & " *" 'lead nothing and lag space
If bIsAMatch Then Exit For
'B = Var
bIsAMatch = sLine Like "* " & sDec 'lead space and lag nothing
If bIsAMatch Then Exit For
'Sub Name(Var, etc)
bIsAMatch = sLine Like "*(" & sDec & ",*" 'lead opening bracket and lag comma
If bIsAMatch Then Exit For
'B = C(n + Var)
bIsAMatch = sLine Like "* " & sDec & ")*" 'lead space and lag close bracket
If bIsAMatch Then Exit For
'B = "t" & Var.Name
bIsAMatch = sLine Like "* " & sDec & ".*" 'lead space and lag dot
If bIsAMatch Then Exit For
'B = C(Var + n)
bIsAMatch = sLine Like "*(" & sDec & " *" 'lead open bracket and lag space
If bIsAMatch Then Exit For
'B = (Var)
bIsAMatch = sLine Like "*(" & sDec & ")*" 'lead open bracket and lag close bracket
If bIsAMatch Then Exit For
'Var.Value = 5
bIsAMatch = sLine Like sDec & ".*" 'lead nothing and lag dot
If bIsAMatch Then Exit For
'A = Var(a, b)
'Redim Var(1 to 6, 3 to 8) 'ie: redim is commonly treated as use, but never as declaration.
bIsAMatch = sLine Like "* " & sDec & "(*" 'lead space and lag open bracket
If bIsAMatch Then Exit For
'Var(a) = 1
bIsAMatch = sLine Like sDec & "(*" 'lead nothing and lag open bracket
If bIsAMatch Then Exit For
'B = (Var.Name)
bIsAMatch = sLine Like "*(" & sDec & ".*" 'lead opening bracket and lag dot
If bIsAMatch Then Exit For
'SubName Var, etc
bIsAMatch = sLine Like "* " & sDec & ",*" 'lead space and lag comma
If bIsAMatch Then Exit For
'B = (Var(a) - c)
bIsAMatch = sLine Like "*(" & sDec & "(*" 'with lead open bracket and lag open bracket
If bIsAMatch Then Exit For
'Test Var:=Name
bIsAMatch = sLine Like "* " & sDec & ":*" 'lead space and lag colon
If bIsAMatch Then Exit For
'Test(A:=1, B:=2)
bIsAMatch = sLine Like "*(" & sDec & ":*" 'lead opening bracket and lag colon
If bIsAMatch Then Exit For
'SomeSub str:=Var
bIsAMatch = sLine Like "*:=" & sDec 'lead colon equals and lag nothing
If bIsAMatch Then Exit For
'test arg1:=b, arg2:=A + 1
bIsAMatch = sLine Like "*:=" & sDec & " *" 'lead colon equals and lag space
If bIsAMatch Then Exit For
'test arg1:=b, arg2:=A(1) + 1
bIsAMatch = sLine Like "*:=" & sDec & "(*" 'lead colon equals and lag opening bracket
If bIsAMatch Then Exit For
'SomeSub (str:=Var)
bIsAMatch = sLine Like "*:=" & sDec & ")*" 'lead colon equals and lag closing bracket
If bIsAMatch Then Exit For
'SomeSub str:=Var, etc
bIsAMatch = sLine Like "*:=" & sDec & ",*" 'lead colon equals and lag comma
If bIsAMatch Then Exit For
'SomeSub str:=Var.Value etc
bIsAMatch = sLine Like "*:=" & sDec & ".*" 'lead colon equals and lag dot
If bIsAMatch Then Exit For
'SomeModule.Var.Font.Size = 10
' bIsAMatch = sLine Like "*." & sDec & ".*" 'lead dot and lag dot
' If bIsAMatch Then Exit For
'SomeModule.Var(2) = 5
' bIsAMatch = sLine Like "*." & sDec & "(*" 'lead dot and lag opening bracket
' If bIsAMatch Then Exit For
'SomeModule.Var = 3
' bIsAMatch = sLine Like "*." & sDec & " *" 'lead dot and lag space
' If bIsAMatch Then Exit For
Next n
If bIsAMatch Then
PatternCheck = True
'MsgBox "Match found"
Exit Function
Else
'MsgBox "No match found"
'Exit Function
End If
End Function
Sub AutoLayout(vA As Variant, Optional bTranspose As Boolean = False)
' Takes array vA of say, 4 columns of data and
' displays on textbox in tabular layout.
' Needs a userform called ViewVars and a textbox
' called Textbox1. Code will adjust layout.
' Transpose2DArr used only to return data to (r, c) format.
Dim vB As Variant, vL As Variant, vR As Variant
Dim r As Long, c As Long, m As Long, sS As String
Dim nNumPadSp As Long, TxtLab As Control, MaxFormWidth As Long
Dim sAccum As String, sRowAccum As String, bBold As Boolean
Dim nLineLen As Long, BoxFontSize As Long, BoxFontName As String
Dim sLabAccum As String, nLabPadSp As Long, oUserForm As Object
Dim Backshade As Long, BoxShade As Long, BoxTextShade As Long
Dim ButtonShade As Long, ButtonTextShade As Long
Dim Lb1 As Long, Ub1 As Long, Lb2 As Long, Ub2 As Long
Dim TextLength As Long, bItalic As Boolean
' decide to transpose input or not
If bTranspose = True Then
Transpose2DArr vA, vR
vA = vR
End If
' get bounds of display array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vL(Lb2 To Ub2) ' make labels array
ReDim vB(Lb2 To Ub2) ' dimension column width array
'--------------------------------------------------------------
' SET USER OPTIONS HERE
'--------------------------------------------------------------
' set the name of the userform made at design time
Set oUserForm = ViewVars
' set limit for form width warning
MaxFormWidth = 800
' make column labels for userform - set empty if not needed
vL = Array("Variable", "Procedure", "Module", "Project")
' colors
Backshade = RGB(31, 35, 44) 'almost black - used
ButtonShade = RGB(0, 128, 128) 'blue-green - not used
BoxShade = RGB(0, 100, 0) 'middle green - used
ButtonTextShade = RGB(230, 230, 230) 'near white - not used
BoxTextShade = RGB(255, 255, 255) 'white - used
' Font details are to be found below
'--------------------------------------------------------------
' find maximum width of array columns
' taking account of label length also
For c = Lb2 To Ub2
m = Len(vL(c)) 'label
For r = Lb1 To Ub1
sS = vA(r, c) 'value
If Len(sS) >= m Then
m = Len(sS)
End If
Next r
'exits with col max array
vB(c) = m
m = 0
Next c
' For testing only
' shows max value of each column
' For c = LB2 To UB2
' MsgBox vB(c)
' Next c
For r = Lb1 To Ub1
For c = Lb2 To Ub2
If c >= Lb2 And c < Ub2 Then
' get padding for current element
nNumPadSp = vB(c) + 2 - Len(vA(r, c))
Else
' get padding for last element
nNumPadSp = vB(c) - Len(vA(r, c))
End If
' accumulate line with element padding
sAccum = sAccum & vA(r, c) & Space(nNumPadSp)
' get typical line length
If r = Lb1 Then
sRowAccum = sRowAccum & vA(Lb1, c) & Space(nNumPadSp)
nLineLen = Len(sRowAccum)
End If
Next c
' accumulate line strings
sAccum = sAccum & vbNewLine
Next r
' accumulate label string
For c = Lb2 To Ub2
If c >= Lb2 And c < Ub2 Then
' get padding for current label
nLabPadSp = vB(c) + 2 - Len(vL(c))
Else
' get padding for last element
nLabPadSp = vB(c) - Len(vL(c))
End If
' accumulate the label line
sLabAccum = sLabAccum & vL(c) & Space(nLabPadSp)
Next c
' load user form
Load oUserForm
'================================================================
' SET FONT DETAILS HERE. THESE AFFECT ALL AUTOSIZING.
'================================================================
BoxFontSize = 12 'say between 6 to 20 points
bBold = True 'True for bold, False for regular
bItalic = False 'True for italics, False for regular
BoxFontName = "Courier" 'or other monospaced fonts eg; Consolas
'================================================================
' make the labels textbox
Set TxtLab = oUserForm.Controls.Add("Forms.TextBox.1", "TxtLab")
' format the labels textbox
With TxtLab
.WordWrap = False
.AutoSize = True 'extends to fit text
.Value = ""
.font.Name = BoxFontName
.font.SIZE = BoxFontSize
.font.Bold = bBold
.font.Italic = bItalic
.ForeColor = BoxTextShade
.Height = 20
.Left = 20
.Top = 15
.Width = 0
.BackStyle = 0
.BorderStyle = 0
.SpecialEffect = 0
End With
'apply string to test label to get length
TxtLab.Value = sLabAccum & Space(4)
TextLength = TxtLab.Width
'MsgBox TextLength
'format userform
With oUserForm
.BackColor = Backshade
.Width = TextLength + 40
.Height = 340
.Caption = "Redundant variables list..."
End With
' check user form is within max width
If oUserForm.Width > MaxFormWidth Then
MsgBox "Form width is excessive"
Unload oUserForm
Exit Sub
End If
'format the data textbox
With oUserForm.TextBox1
.ScrollBars = 3
.WordWrap = True
.MultiLine = True
.EnterFieldBehavior = 1
.BackColor = BoxShade
.font.Name = BoxFontName
.font.SIZE = BoxFontSize
.font.Bold = bBold
.font.Italic = bItalic
.ForeColor = BoxTextShade
.Height = 250
.Left = 20
.Top = 40
.Width = TextLength
.Value = sAccum
End With
'show the user form
oUserForm.Show
End Sub