应用程序/冗余变量列表
< 应用程序
这个非常长的代码模块列出了一个 Excel 项目的冗余变量。
运行顶部过程会检查ThisWorkbook的 VBA 项目，即运行代码的工作簿。它生成工作表和用户窗体输出。代码在一个模块中自包含，但此外，用户需要创建一个名为ViewVars的用户窗体，其中包含一个名为TextBox1的文本框。细节并不重要，因为显示会在代码中根据内容进行调整。但是，用户窗体的属性ShowModal应该设置为False，Multiline设置为True。通过在RunVarChecks中将布尔变量bUseWorkSheets设置为True，可以获得一种测试模式。但请注意，这将在写入第一到第五张表之前清除所有现有工作表。为了强调这一点，如果您的意图是不干扰项目表一到五的内容，那么请确保RunVarChecks的bUseWorkSheets设置为False；在代码运行几秒后，冗余变量仍将在用户窗体ViewVars中列出。
有一些限制
- 列表只能适用于编译正确的代码；也就是说，即使不是有效的代码，也需要合理的结构。
- API 变量声明和常量枚举不受处理。也就是说，即使它们是冗余的，也不会列出。
- 该模块被编码为与ThisWorkbook的 VBAProject 一起工作。但是，对于那些打算检查其他工作簿对象的用户来说，有一个可选参数可以访问另一个工作簿对象。
- 该模块适用于常见的 VBA 变量命名方法。这包括使用公共同名变量和完整表达的变量描述。它通过搜索复合相似变量及其简单形式来做到这一点。例如，尽管很少见，但三种形式myvar、Module1.myvar和VBProject.Module1.myvar都可以在代码中用于同一个变量。使用这些形式允许在任何模块标题中使用相同的变量名，而不会发生冲突。
- 为输出结果和测试制作了多个工作表列表。用户应该确保存在 1 到 5 号表，因为代码不会在此列表中创建它们。如果它们与其他用途发生冲突，用户可能希望限制或更改主过程中的这些列表。一个单独的用户窗体输出利用了过程AutoLayout。
- 用户窗体样式可能不适合所有人，但可以在过程AutoLayout的两个用户部分中更改颜色和字体。但是，请记住，所选字体必须是等宽字体，以便布局整洁。除了这个限制之外，布局将处理大约 6 到 20 点之间的任何常规字体大小，以及粗体和斜体变体。也就是说，代码会自动调整用户窗体的布局和大小，以生成有用的显示。
- 过程没有被标记为模块Private。当用户也使用本系列中的其他模块时，可能会遇到同名过程。将来，如果它们看起来是在其他地方使用过，我将尝试记住将它们标记为模块私有。
- 感兴趣的各方可能希望通报任何错误。请只使用讨论页面，我会尽快回复。
- 一般方法是创建一个声明的变量列表，然后测试每个变量条目，看看它是否被使用。
- 项目字符串包含项目中的所有代码。该字符串逐行加载到工作数组中，并在各个过程之间以变量形式传递。
- 还添加了过程、模块和项目名称信息。每行代码都用这些信息标记。
- 删除引号和注释，因为它们可能包含任何文本，可能会混淆决策过程。
- 继续行的存在也会造成混淆，因此在解释之前，将它们全部合并成单行。
- 共享标签行和行号也会造成困难，因此标签被赋予单独的行，并且行号在任何决策过程之前被分离。
- 空白行不需要，因此被删除。由于行数发生了变化，因此项目工作数组被重新编号。
- 每行代码都用其住宅行范围标记。每行都用其所在过程和模块的代码行范围进行标记。这些数据随后可以轻松找到。
- 声明的变量列表，即数组vDec，包含项目中的每个声明变量。
- 它列出了每个变量的所有其他相关数据。每个变量的作用域被确定并添加。名义搜索行范围也被添加。这些是在知道变量的作用域后最初看到的行范围。例如，过程级声明将显示过程行范围，模块私有项将显示模块的行范围。
- 当变量被找到使用时，它们在vDec上被标记。搜索顺序是，所有过程级变量，然后是模块私有变量，最后是公共变量。当具有不同作用域的同名变量存在时，此顺序很有用，因为它会逐渐减少所需的搜索范围。
- 在决定使用哪种搜索方法之前，会检查每个变量的命名歧义。只有在没有命名歧义的情况下才能采用所谓的正常方法；即；搜索整个名义行范围。否则，需要修改名义搜索范围，以避免已找到同名变量的区域。例如，模块变量搜索不会查看已经声明和使用过同名变量的过程，但如果那里没有声明同名项，则会进行检查。
- 公共变量和模块级变量必须用三个名称进行检查。变量的完整名称可以包括项目、模块和变量名称，也可以只包括模块和变量名称，以及更常见的短名称。
- 公共变量的处理方式略有不同。这些变量可以在每个模块中使用相同的名称存在。对于公共变量，有两种可能的重复名称：首先，有一种公共变量的名称与任何数量的过程中的变量相同，其次，在多个模块标题中使用相同的名称作为公共变量。在这些同名情况下，如果公共变量的使用不在其声明的模块中，则至少需要模块和变量名称。
- 大多数情况下，公共变量的名称是完全唯一的。也就是说，项目中没有其他变量具有相同的名称。在这种情况下，可以在整个项目中无限制地搜索变量的使用情况。
- 如果公共变量在其他模块标题中没有同名变量，但在模块或过程变量中存在同名变量，那么必须在整个项目中搜索其使用情况，同时考虑来自已找到这些同名变量的模块和过程的行限制。
- 如果公共变量在多个模块标题中具有同名变量，则确定变量使用情况必须分两步进行：
- 必须使用公共变量的两种复合形式在整个项目中进行无限制地搜索
- 然后在声明公共变量的模块中进行搜索，同时考虑那里来自同名变量的任何过程限制。
- 经过所有这些之后，任何没有被标记为使用的变量都可以被列为冗余的。
将单词aliases修改为similars（2018 年 1 月 15 日）。
修改了AutoLayout()，以避免表单中的回绕。标签长度加上 4 个空格，而不是 2 个（2017 年 9 月 17 日）。
添加了关于需要VBA Extensibility 5.3的说明，并测试了代码 - 工作正常。（2016 年 12 月 31 日）
修改了AutoLayout()以减少控件数量。（2016 年 11 月 17 日）。
修改了AutoLayout()以获得更好的字体选择。（2016 年 11 月 16 日）。
在AutoLayout()中添加了更简单的字体选项。（2016 年 11 月 16 日）。
修改了动态数组中的代码，并在RunVarChecks()中添加了测试模式开关bUseWorkSheets。（2016 年 11 月 15 日）。
删除了一个冗余过程，并修正了 TrimStr 错误。（2016 年 11 月 13 日）。
在 MarkPubVarUse() 中修正了对 NewPubRange() 的代码调用。现在参数行包含整个项目。(2016 年 11 月 8 日)
对用户表单显示过程进行了更改。(2016 年 11 月 7 日)
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