應用程式/冗餘變數列表
< 應用程式
這個非常長的程式碼模組列出了一個 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