Visual Basic for Applications/VBA 程式碼縮排器
- 這個公認的較長程式碼模組用於縮排或格式化剪貼簿中找到的任何 VBA 程式碼。 它使用相當標準的程式碼縮排規則，可以在此頁面程式碼的格式中看到示例。現在，用於 64 位 Windows 中 VBA 編輯器的商業格式化實用程式已經可用，但下面的程式碼不是作為載入項執行，而是作為簡單的 VBA 程式碼模組執行。在一定範圍內，它適用於所有最新的 Windows 和 Excel 版本，以及可以執行 VBA 的其他Microsoft Office應用程式。對於即使是最挑剔的使用者來說，它也足夠快。
- 它將縮排後的文字放回剪貼簿以替換原始文字。 使用者可以隨意貼上它。
- 第一次嘗試只有很少的選項.
- 可以設定縮排深度。 這是透過設定每個製表符的空格數來完成的。
- 可以設定連續空白行的數量。 這限制為無、一個或按發現的原樣保留。
- 可以保留或刪除現有的行號，儘管沒有提供重新編號的功能。
- 共享的標籤行可以拆分到它們自己的行上。
- 程式碼通常將作為續行的註釋替換為它們自己行上的註釋，儘管使用者可以選擇完全避免對註釋進行更改。如果允許更改註釋
- Rem 註釋樣式可選地替換為單引號樣式。
- 使用者可以選擇在註釋單引號後插入一個空格，或者在單引號已經存在的地方將其刪除。
幾點值得一提
- 程式碼作為單個完整的標準模組執行。 執行過程Indenter() 以縮排剪貼簿內容。
- 使用者也可以考慮使用可選的使用者窗體 來預覽縮排後的輸出字串（過程Indenter 中的sRet）然後進行貼上。
- 選擇具有完整配對的程式碼 以最大程度地利用縮排器。例如，這樣就沒有明顯的沒有End If的If。也就是說，可以縮排程式碼片段、過程或整個模組。實際上，任何具有識別出的 VBA 關鍵字和換行符的文字都將被縮排。使用者應將 VBA 編輯器錯誤設定設定為中斷未處理的錯誤 以避免來自有意引發錯誤的不必要中斷。
- 發現此事有趣 的讀者 可以在討論中新增任何錯誤報告，我會在有空時檢視它們。
所有工作都在模組級字串陣列中完成。過程是
- 首先獲取剪貼簿字串。 用於獲取字串的方法與本系列中其他地方列出的方法相同。有關DataObject 剪貼簿方法，請參閱剪貼簿 VBA。此方法取代了先前使用虛擬使用者窗體的方法。
- 使用字串作為一組行載入陣列。 只加載程式碼部分，不載入可能存在的任何行號。然後從每一行刪除現有的縮排。這意味著任何前導和尾隨空格和製表符。
- 重新連線用延續標記斷開的行。 此過程避免了許多行識別問題，尤其是來自沒有自己延續標記的摺疊的後續註釋行。
- 識別並使用行型別標記陣列。 出現在封閉結構（如For...Next 或Sub...End Sub 對）中的行型別對於縮排特別重要。這些分別標記為開始 和結束 行型別。最初，哪些 結構並不重要，重要的是它們是否是開始或結束。中間 行（如Else）也需要識別，以及註釋、空白 行，以及一大組所謂的其他 行。
- 匹配相應的開始 和結束 行。 它是這樣工作的：從程式碼的頂部開始；選擇第一個開始 行並將其計為一個，然後向下移動，增加開始 和結束 計數器，直到兩個計數器相等；然後找到匹配的結束 行。在重置計數器後，向下移動到第二個開始，並重復此過程，直到所有開始 行都已匹配。陣列開始 行用相應結束 匹配的行號標記。
- 檢查配對計數。 如果程式碼不包含至少一個開始-結束結構，或者開始 和結束 總數不匹配，則會邀請使用者繼續 或退出。會引發使用者分配的錯誤來實現退出。
- 為主要結構分配縮排和縮出計數。 從程式碼行的頂部開始，轉到標記為開始 的第一行。為位於該開始 行與其相應結束 行之間的所有行新增一個縮排計數。向下移動到下一個開始 行，並重復此過程，直到完成。現在，對於陣列中任何標記為中間 的行，縮出，即減去一個縮排計數。縮排計數使用縮排選項轉換為空格。
- 將縮排空格加入程式碼行並從中製作一個字串。 儘管使用者可以設定間距選項，但每個縮排單元四個空格似乎最有用，就像 VBA 編輯器本身一樣。
- 將縮排後的字串上傳到剪貼簿，然後提示它已存在，準備貼上。
2018 年 12 月 15 日：程式碼修改為在剪貼簿不是文字時新增錯誤。
2018 年 12 月 14 日：程式碼修改為使用DataObject 複製和貼上方法。
2017 年 3 月 29 日：對 GetClipboard 函式註釋進行了輕微編輯。
Option Explicit
Private sW() As String
Sub Indenter()
' ===============================================================================
' Run the sub "Indenter" to format any VBA code text that is on the clipboard.
' The indented version will be found on the clipboard, replacing the original.
' ===============================================================================
Dim sClip As String, msg As String
Dim vT As Variant, vU As Variant, vS As Variant, sRet As String
Dim bModifyComments As Boolean, bMC As Boolean, bOnlyAposComments As Boolean
Dim bOAC As Boolean, bApostropheSpaced As Boolean, bAS As Boolean
Dim bSplitLabelLines As Boolean, bSL As Boolean, bKeepLineNumbers As Boolean
Dim bKLN As Boolean, nSpacesPerIndentTab As Long, nSPIT As Long
Dim nMaxAdjacentBlankLines As Long, nMABL As Long
' ===============================================================================
' SET USER OPTIONS HERE
' ===============================================================================
nSpacesPerIndentTab = 4 ' Sets number of spaces per tab - depth of indenting,
' ' best settings found to be 2, 3, or 4.
'---------------------------------------------------------------------------------
nMaxAdjacentBlankLines = 7 ' Sets number of adjacent blank lines in output
' ' 0 for none, or 1. Set > 1 to leave as found.
'---------------------------------------------------------------------------------
bModifyComments = False ' True to allow other modifications to comments, and
' ' changing of continuation comment groups into own-line
' ' comments. False, for no changes to comments.
' 'set bModifyComments to true for these to have any effect;
bOnlyAposComments = True ' True to change any r e m style comments to
' ' to apostrophe style, else false to leave as found.
bApostropheSpaced = False ' True to place spaces after apostrophies in
' ' comments, else False to remove any single space.
'---------------------------------------------------------------------------------
bSplitLabelLines = False ' True to split label lines onto own lines if they
' ' are shared, else False to leave as they are found.
'---------------------------------------------------------------------------------
bKeepLineNumbers = True ' True to preserve existing line numbers, if any,
' ' else False to remove any numbers during indent.
'---------------------------------------------------------------------------------
'
' ================================================================================
nSPIT = nSpacesPerIndentTab: nMABL = nMaxAdjacentBlankLines
bMC = bModifyComments: bOAC = bOnlyAposComments: bAS = bApostropheSpaced
bSL = bSplitLabelLines: bKLN = bKeepLineNumbers
On Error GoTo Err_Handler
Erase sW() ' erase work array
' ---------------------------------------------------------------------------------
sClip = GetFromClip ' GETS CLIPBOARD STRING
ProjStrTo1DArr sClip, vS ' String of lines to 1D array of lines. Base zero.
ModifyComments vS, vT, bOAC, bAS, bMC ' Modifies comments; removes continuation
LabelLineSplit vT, vU, bSL ' 1D array to 1D array. Splits shared label lines.
ClpToArray vU ' 1D array to 2D module array. Separates line numbers.
JoinBrokenLines ' 2D array. Joins-up continuation lines.
GetLineTypes ' 2D array. Marks array with line types.
MatchPairs ' 2D array. Matches-up starts and ends.
CheckPairs ' 2D array. Crude checking by pair counts.
Indents ' 2D array. Adds tab counts for indents
Outdent ' 2D array. Subtracts tab count for outdents.
SpacePlusStr nSPIT, bKLN ' 2D array. Adds indent spaces to line strings.
MaxBlanks sRet, nMABL ' 2D array to STRING. Also limits blank lines.
CopyToClip sRet ' INDENTED STRING TO CLIPBOARD
MsgBox "The indented string is now on the clipboard."
' ---------------------------------------------------------------------------------
Exit Sub
Err_Handler:
If Err.Number <> 0 Then
Select Case Err.Number
Case 12345 ' raised in CheckPairs
' optional exit - user selected exit
' partial selection has mismatched structure bounds
' or only trivial text without structures at all
Err.Clear
Exit Sub
Case 12346 ' raised in JoinBrokenLines
' compulsory exit
' partial selection breaks a statement continuation group
Err.Clear
Exit Sub
Case 12347 ' raised in ModifyComments
' compulsory exit
' partial selection breaks a comment continuation group
Err.Clear
Exit Sub
Case -2147221404 'clipboard data object not text
MsgBox "Clipboard does not contain text - closing"
Err.Clear
Exit Sub
Case Else
' all other errors
msg = "Error # " & str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
Err.Clear
MsgBox msg, vbCritical, "Error"
Exit Sub
End Select
End If
End Sub
Function CopyToClip(sIn As String) As Boolean
'passes the parameter string to the clipboard
'set reference to Microsoft Forms 2.0 Object Library.
'Clipboard cleared when launch application closes.
Dim DataOut As DataObject
Set DataOut = New DataObject
'first pass textbox text to dataobject
DataOut.SetText sIn
'then pass dataobject text to clipboard
DataOut.PutInClipboard
'release object variable
Set DataOut = Nothing
CopyToClip = True
End Function
Function GetFromClip() As String
'passes clipboard text to function name
'If clipboard not text, an error results
'set reference to Microsoft Forms 2.0 Object Library.
'Clipboard cleared when launch application closes.
Dim DataIn As DataObject
Set DataIn = New DataObject
'clipboard text to dataobject
DataIn.GetFromClipboard
'dataobject text to function string
GetFromClip = DataIn.GetText
'release object variable
Set DataIn = Nothing
End Function
Sub ProjStrTo1DArr(sIn As String, vR As Variant)
' Input is a string of code lines that are newline separated
' Output is a 1D array containing the set of lines
'vR IS ZERO BASED
Dim LB As Long, UB As Long
' split clipboard string into lines
If sIn <> "" Then
vR = Split(sIn, vbNewLine)
LB = LBound(vR): UB = UBound(vR)
Else
Exit Sub
End If
End Sub
Sub ModifyComments(vA As Variant, vR As Variant, _
Optional bOnlyAposComments As Boolean = True, _
Optional bApostropheSpaced As Boolean = True, _
Optional bEnable As Boolean = True)
'Input 1D array vA; Output 1D array vR
'Changes all comment continuation groups into
'stand-alone comments, and modifies comments.
'Comments are modified in ApostropheSpaces().
'When bDisable is true, the input array is returned intact
'vR IS BASE ZERO
Dim vB As Variant, bHasMarker As Boolean
Dim m As Long, n As Long, LB1 As Long, UB1 As Long
Dim sL As String, sFP As String, sT As String
Dim sCom1 As String, sCom As String, sComR As String
Dim sR1 As String, sR2 As String, sR4 As String, sR5 As String
Dim bOAC As Boolean, bAS As Boolean
bOAC = bOnlyAposComments
bAS = bApostropheSpaced
'use a work array
LB1 = LBound(vA): UB1 = UBound(vA)
'enable or disable proc
If bEnable = False Then
ReDim vR(LB1 To UB1)
vR = vA
Exit Sub
Else
ReDim vB(LB1 To UB1)
vB = vA
End If
'misc string definitions
sR1 = Chr(82) & Chr(101) & Chr(109) & Chr(32) 'R e m + spc
sR2 = Chr(82) & Chr(101) & Chr(109) & Chr(58) 'R e m + colon
sR4 = Chr(39) 'apost
sR5 = Chr(39) & Chr(32) 'apost + spc
'LOOP THROUGH CODE LINES
For n = LB1 To UB1
m = n ' use internal loop counter
sL = vB(m) ' get line string
If sL = "" Then GoTo NextArrayLine
' test whether line string qualifies at all
SplitStrAndComment sL, sFP, sCom
' FIND IF LINE HAS COMMENT
If sCom <> "" Then 'line contains a comment
' FIND FIRST LINE OF CONTINUATION GROUP
If Right$(sL, 2) = " _" Then 'found first of group
' remove comment's continuation markings
sCom1 = Left$(sCom, Len(sCom) - 2)
' do the modifications
ApostropheSpaces sCom1, sComR, bOAC, bAS
vB(m) = sFP & sComR ' update with remake
m = m + 1 'increment group counter
' catch exception for incomplete group
If m > UB1 Then
MsgBox "Broken continuation group detected." & vbCrLf & _
"Please make a more complete selection."
Err.Raise 12347
Exit Sub
Else
' do other parts of continuation group
GoTo DoRestOfGroup
End If
Else
' HAS COMMENT BUT NO CONTINUATION
sCom1 = sCom
' do the modifications
ApostropheSpaces sCom1, sComR, bOAC, bAS
vB(m) = sFP & sComR ' update with remake
' go to next array line
GoTo NextArrayLine
End If
Else
' HAS NO COMMENT AT ALL
GoTo NextArrayLine
End If
DoRestOfGroup:
'PROCESS SECOND GROUP LINE UP TO LAST
Do Until m > UB1
sL = Trim(vB(m)) ' get line string
bHasMarker = sL Like sR1 & "*" Or sL Like sR2 & "*" _
Or sL Like sR4 & "*" Or sL Like sR5 & "*"
If bHasMarker = False Then
sL = sR5 & sL ' add comment mark
End If
' modify and exit for line group last
If Right$(sL, 2) <> " _" Then
ApostropheSpaces sL, sComR, bOAC, bAS ' modify comment
vB(m) = sComR ' update array
n = m - 1 ' update loop counter
Exit Do 'group ending complete
End If
' modify and go to next if not group last
sL = Left$(sL, Len(sL) - 2) 'remove cont mark
ApostropheSpaces sL, sComR, bOAC, bAS ' modify comment
vB(m) = sComR ' update array
m = m + 1 'increment group counter
If m > UB1 Then
MsgBox "Broken continuation group detected." & vbCrLf & _
"Please make a more complete selection."
Err.Raise 12347
Exit Sub
End If
Loop
' go to next array line
GoTo NextArrayLine
NextArrayLine:
' resets
bHasMarker = False
sCom = "": sCom1 = "": sComR = ""
m = 0: sL = "": sFP = "": sT = ""
Next n
Transfers:
ReDim vR(LB1 To UB1)
vR = vB
End Sub
Function ApostropheSpaces(sIn As String, sOut As String, _
Optional bOnlyAposComments As Boolean = True, _
Optional bApostropheSpaced As Boolean = False) As Boolean
' Comment string in, modified comment string out
' These always start with one of two comment marker styles;
' r e m style or apostrophe style. Each has variations.
' At present, sIn broken line parts arrive apostrophied.
' ASCI values of work characters
' asterisk; chr(42), apostrophe; chr(39), double-quote; chr(34)
' R: chr(82),e: chr(101),m: chr(109),colon: chr(58)
Dim sR3 As String, sL As String, bModComments As Boolean
Dim sR1 As String, sR2 As String, sR4 As String, sR5 As String, bHasMarker As Boolean
' String definitions
sR1 = Chr(82) & Chr(101) & Chr(109) & Chr(32) 'R e m + spc
sR2 = Chr(82) & Chr(101) & Chr(109) & Chr(58) 'R e m + colon
sR4 = Chr(39) 'apost
sR5 = Chr(39) & Chr(32) 'apost + spc
bModComments = True ' true to apply local changes, else false to return sIn.
If bModComments = False Then
sOut = sL
Exit Function
End If
'get line string
sL = sIn
' Find if line fits any comment pattern
bHasMarker = sL Like sR1 & "*" Or sL Like sR2 & "*" _
Or sL Like sR4 & "*" Or sL Like sR5 & "*"
If bHasMarker = True Then
' REPLACE REM STYLE WITH APOSTROPHE
If bOnlyAposComments = True Then
' take first four charas of comment...
sR3 = Left$(sL, 4)
'if they fit r e m pattern...
If sR3 = sR1 Or sR3 = sR2 Then
'change the first four to an apostrophe
sR3 = Replace(sL, sR3, sR4, 1, 1)
sL = sR3
sR3 = ""
End If
End If
' SET SPACE BEFORE APOSTROPHE
If bApostropheSpaced = True Then
' take first two charas of comment...
sR3 = Left$(sL, 2)
'if they fit apostrophe pattern...
If sR3 <> sR5 Then
'change the first two to an apostrophe
sR3 = Replace(sL, sR4, sR5, 1, 1)
sL = sR3
sR3 = ""
End If
Else
' bApostropheSpaced is false so remove short space.
' provided that no more than one existing space,
' replace first instance of apos + spc with just apos.
If Left$(sL, 3) <> sR5 & Chr(32) And Left$(sL, 2) = sR5 Then
sR3 = Replace(sL, sR5, sR4, 1, 1)
sL = sR3
sR3 = ""
End If
End If
Else
MsgBox "Pattern failure in ApostropheSpaces"
Exit Function
End If
sOut = sL
ApostropheSpaces = True
End Function
Function LabelLineSplit(vA As Variant, vR As Variant, Optional bEnable As Boolean = True) As Boolean
'Input vA, 1D array with block of code lines.
'Output vR, 1D array with label lines split.
'Increases line count when if splitting is done
'Takes account of line continuations in decision making.
'When bDisable is true, the input array is returned intact
'vR IS BASE ZERO
Dim n As Long, sRC As String, vC As Variant
Dim sLN As String, sLL As String
Dim sL As String, sS As String, bPrevIsBroken As Boolean
Dim LBvA As Long, UBvA As Long, UB As Long
LBvA = LBound(vA): UBvA = UBound(vA)
'enable or disable proc
If bEnable = False Then
ReDim vR(LBvA To UBvA)
vR = vA
Exit Function
Else
ReDim vR(LBvA To 0)
End If
sRC = Chr(82) & Chr(101) & Chr(109) 'r e m
'Conditional transfer of lines
For n = LBvA To UBvA
'get full line string
sL = Trim(vA(n))
'exclusions
'tranfer intact if line blank or
'either kind of comment
If sL = "" Or Left$(sL, 1) = Chr(39) Or _
Left$(sL, 3) = sRC Then
ReDim Preserve vR(LBound(vR) To UBound(vR) + 1)
UB = UBound(vR)
vR(UB) = Trim(sL)
GoTo SkipThisOne
End If
' find if it has a label
If n = LBvA Then
' for first line only
' assume worth splitting
SplitLineParts sL, sLN, sLL, sS
Else ' for all lines after first
' test to see if prev line continued
bPrevIsBroken = Trim(vA(n - 1)) Like "* _"
If Not bPrevIsBroken Then 'test for label
SplitLineParts sL, sLN, sLL, sS
Else
' CONTINUATION SO TRANSFER IT INTACT
ReDim Preserve vR(LBound(vR) To UBound(vR) + 1)
UB = UBound(vR)
vR(UB) = Trim(sL)
GoTo SkipThisOne
End If
End If
' LABEL ACTION
If sLL <> "" Then
If Trim(sS) <> "" Then
' THERE IS A SHARED LABEL LINE TO SPLIT
ReDim Preserve vR(0 To UBound(vR) + 1)
UB = UBound(vR)
vR(UB) = Trim(sLL) ' label onto line
ReDim Preserve vR(0 To UBound(vR) + 1)
UB = UBound(vR)
vR(UB) = Trim(sS)
Else ' ALREADY ON ITS OWN LINE
' so transfer label to array
ReDim Preserve vR(LBound(vR) To UBound(vR) + 1)
UB = UBound(vR)
vR(UB) = Trim(sLL)
End If
Else ' NOT A LABEL AT ALL SO TRANSFER IT INTACT
ReDim Preserve vR(LBound(vR) To UBound(vR) + 1)
UB = UBound(vR)
vR(UB) = Trim(sL)
End If
SkipThisOne:
sL = "": sLN = "": sLL = "": sS = ""
Next n
Transfers:
ReDim vC(0 To UB - 1)
For n = LBound(vC) To UBound(vC)
vC(n) = vR(n + 1)
Next n
'exit as zero based array
ReDim vR(LBound(vC) To UBound(vC))
vR = vC
End Function
Function SplitStrAndComment(sIn As String, sFirstPart As String, sComment As String) As Boolean
'==============================================================================================
' Returns input-less-comment in sFirstPart and any comment string in sComment.
' Input sIn supplies one VBA code line string, and the two parts are returned untrimmed.
' Has good immunity to suffering and causing corruption from comment and quote text.
' For no comment found, sFirstPart is sIn, and sComment is empty.
' Method: Makes two runs; one search for apostrophe comments, and next for r e m comments;
' Removes any double quote pairs until relevant comment mark is located before any double quote.
' If any results are found, the one without search error has the comment that is longest.
' String stripped of quotes and position of comment mark are available but not returned here.
'==============================================================================================
Dim nPos As Long, sNoQuotes As String, sCmMrk As String
Dim nPos1 As Long, nPos2 As Long, sNoQuotes1 As String
Dim str1 As String, Str2 As String, m As Long
Dim vM As Variant, nLA As Long, nLR As Long, sNoQuotes2 As String
Dim q1 As Long, q2 As Long, a As Long, s1 As String, s2 As String
Dim bQuote As Boolean, bComment As Boolean, sA As String
Dim bACFound As Boolean, bRCFound As Boolean
' ASCI values of work characters
' asterisk; chr(42), apostrophe; chr(39), double-quote; chr(34)
' R: chr(82),e: chr(101),m: chr(109),colon: chr(58)
'two runs; first for apos, then r e m comments
vM = Array(Chr(39), Chr(82) & Chr(101) & Chr(109))
str1 = sIn
'run loop for each of two searches
For m = 1 To 2
'select one of two comment marks to search for
sCmMrk = vM(m - 1) 'zero based
' check the line string patterns
' asterisk; chr(42), apostrophe; chr(39), double-quote; chr(34)
bComment = str1 Like Chr(42) & sCmMrk & Chr(42) ' for an apostrophe
bQuote = str1 Like Chr(42) & Chr(34) & Chr(42) ' for a double quote
If bComment = True And bQuote = True Then
'has comment mark and has double quote
' set initial value
q2 = 1
Do
' get postion of first comment mark
a = InStr(q2, str1 & sCmMrk, sCmMrk)
' get postion of first double quote
q1 = InStr(q2, str1 & Chr(34), Chr(34))
If a <= q1 Then
'found comment
sA = Right$(str1, Len(str1) - a + 1)
nPos = a
sNoQuotes = str1
GoTo Output
ElseIf a > q1 Then
'find next quote
q2 = InStr(q1 + 1, str1 & Chr(34), Chr(34))
'if next quote is found
If q2 <> 0 Then
'remove charas from q1 to q2 inclusive
Str2 = Left$(str1, q1 - 1) & Right$(str1, Len(str1) - q2)
'set new start position for search
q2 = q2 + 1
End If
End If
Loop Until (a = q1)
ElseIf bComment = True And bQuote = False Then
' has comment mark but has no double quote
' so return original str and comment details
str1 = str1
a = InStr(1, str1 & sCmMrk, sCmMrk) ' position of first comment mark
sA = Right$(str1, Len(str1) - a + 1) ' comment string
nPos = a ' return position of comment
sNoQuotes = str1 ' return string without quotes
GoTo Output
Else
' no comment mark but has double quote, or
' no comment mark and no double quote.
' so return original string
sA = ""
nPos = 0
sNoQuotes = str1
GoTo Output
End If
Output:
'get details for each of two searches.
If m = 1 Then 'for apostrophe comment search
nLA = Len(sA) 'apos
s1 = sA
nPos1 = nPos
sNoQuotes1 = sNoQuotes
Else 'for r e m comment search
nLR = Len(sA) 'r e m
s2 = sA
nPos2 = nPos
sNoQuotes2 = sNoQuotes
End If
'select and return details for longest comment
If nLA > nLR Then
bACFound = True 'apos comment flag
nPos = nPos1 'position of comment
sNoQuotes = sNoQuotes1 'de-quoted original
sFirstPart = Left$(str1, nPos - 1) 'str before comment
sComment = s1 'comment string
ElseIf nLR > nLA Then
bRCFound = True 'r e m comment flag
nPos = nPos2 'de-quoted original 'position of comment
sNoQuotes = sNoQuotes2 'de-quoted original
sFirstPart = Left$(str1, nPos - 1) 'str before comment
sComment = s2 'comment string
Else
'no comments found
sFirstPart = str1 'str before comment
sComment = "" 'comment string
End If
Next m
SplitStrAndComment = True
End Function
Sub ClpToArray(vA As Variant)
' loads array with lines of clipboard
'vA IS 1D BASE ZERO ARRAY
'sW() IS 2D BASE ONE MODULE LEVEL ARRAY
Dim n As Long, m As Long, Num As Long
Dim sLN As String, sLS As String
Dim sLN1 As String, sLS1 As String
Dim LBvA As Long, UBvA As Long
Dim bPrevIsBroken As Boolean
Dim sL As String, sLP As String
'get bounds of vA
LBvA = LBound(vA): UBvA = UBound(vA)
' count lines in vA clipboard sample
Num = UBvA - LBvA + 1
' redim array
ReDim sW(1 To 12, 1 To Num)
' load lines
For n = LBvA To UBvA
sL = Trim(vA(n))
If n <> LBvA Then sLP = Trim(vA(n - 1))
' LINE NUMBER SPLIT DEPENDS ON CONTINUED LINES
' split line into line numbers and line strings
' find if it has a line number
If n = LBvA Then ' for first vA line only
' attempt split anyway
SplitLineNums sL, sLN1, sLS1
sLN = sLN1: sLS = sLS1
Else ' for all lines after first
' test to see if prev line continued
bPrevIsBroken = sLP Like "* _"
If Not bPrevIsBroken Then
' LOAD BOTH LINE NUMBER AND LINE STRING
SplitLineNums sL, sLN1, sLS1
sLN = sLN1: sLS = sLS1
Else
' CONTINUATION - LOAD LINE STRING ONLY
' any leading number is not a line number
sLN = "": sLS = sL
End If
End If
m = n + 1
' LOAD MODULE LEVEL STRING ARRAY sW()
sW(1, m) = m ' project line numbers
sW(2, m) = sLS ' trimmed line strings
sW(3, m) = "other" ' code line types
sW(4, m) = 0 ' structure end numbers
sW(5, m) = 0 ' record tab count
sW(6, m) = "" ' indented strings
sW(7, m) = "" ' continuations marking
sW(8, m) = "" ' continuation group strings
sW(9, m) = sLN ' user code line numbers
sW(10, m) = "" ' optional output renumbering
sW(11, m) = "" ' marked if "Proc" or "End Proc"
sW(12, m) = "" ' marked if "Label"
Next n
End Sub
Sub JoinBrokenLines()
' Identifies lines with continuation marks
' Joins these broken lines into one line
' Marks newly redundant lines as "other"
Dim vA As Variant, IsContinuation As Boolean
Dim str As String, saccum As String
Dim n As Long, s As Long, nS As Long, nE As Long
' mark all lines that have a continuation chara
For n = LBound(sW(), 2) To UBound(sW(), 2)
str = sW(2, n) ' line string
IsContinuation = str Like "* _"
If IsContinuation Then sW(7, n) = "continuation"
Next n
' mark the start and end of every continuation group
For n = LBound(sW(), 2) To (UBound(sW(), 2) - 1)
If n = 1 Then ' for the first line only
If sW(7, n) = "continuation" Then sW(8, n) = "SC"
If sW(7, n) = "continuation" And sW(7, n + 1) <> "continuation" _
Then sW(8, n + 1) = "EC"
Else ' for all lines after the first
' find ends
If sW(7, n) = "continuation" And sW(7, n + 1) <> "continuation" Then
sW(8, n + 1) = "EC"
End If
' find starts
If sW(7, n) = "continuation" And sW(7, n - 1) <> "continuation" Then
' If sW(7, n) <> "continuation" And sW(7, n + 1) = "continuation" Then
sW(8, n) = "SC"
End If
End If
Next n
' Count continuation group starts and ends
For n = LBound(sW(), 2) To UBound(sW(), 2)
If sW(8, n) = "SC" Then nS = nS + 1
If sW(8, n) = "EC" Then nE = nE + 1
Next n
If nS <> nE Then
' Error. Means there is an incomplete continuation selection
' Advise, raise error and exit
MsgBox "The selection made is not sufficiently complete." & vbCrLf & _
"A line that is continued has parts missing." & vbCrLf & _
"Please make a another selection."
Err.Raise 12346
Exit Sub
End If
' make single strings from each continuation group
For n = LBound(sW(), 2) To (UBound(sW(), 2) - 1)
If sW(8, n) = "SC" Then ' group starts
' join strings to make one string per continuation group
s = n
vA = Split(CStr(sW(2, n)), "_")
str = CStr(vA(0))
saccum = str
Do Until sW(8, s) = "EC"
s = s + 1
sW(3, s) = "other" ' mark all but first line in group as "other"
vA = Split(CStr(sW(2, s)), "_")
str = CStr(vA(0))
saccum = saccum & str
Loop
sW(8, n) = saccum ' place at first line level in array
End If
str = ""
saccum = ""
s = 0
Next n
End Sub
Sub GetLineTypes()
' Marks array with the indentable closed structures
Dim n As Long, m As Long, str As String
Dim bProc As Boolean
Dim Outdents, StructureStarts, StructureEnds, bEndProc As Boolean
Dim IsComment As Boolean, IsBlank As Boolean
Dim IsContinuation As Boolean, IsOK As Boolean
' THESE PATTERNS DECIDE HOW STRUCTURES ARE INDENTED - (revised Oct. 2016)
' ================================================================================
' STARTS LIST - starts of structures that contain lines to indent
StructureStarts = Array( _
"Do", "Do *", "Do: *", _
"For *", _
"If * Then", "If * Then: *", "If * Then [!A-Z,!a-z]*", _
"Select Case *", _
"Type *", "Private Type *", "Public Type *", _
"While *", _
"With *", _
"Sub *", "Static Sub *", "Private Sub *", "Public Sub *", "Friend Sub *", _
"Private Static Sub *", "Public Static Sub *", "Friend Static Sub *", _
"Function *", "Static Function *", "Private Function *", _
"Public Function *", "Friend Function *", "Private Static Function *", _
"Public Static Function *", "Friend Static Function, *", _
"Property Get *", "Static Property Get *", "Private Property Get *", _
"Public Property Get *", "Friend Property Get *", _
"Private Static Property Get *", "Public Static Property Get *", _
"Friend Static Property Get *", _
"Property Let *", "Static Property Let *", "Private Property Let *", _
"Public Property Let *", "Friend Property Let *", _
"Private Static Property Let *", "Public Static Property Let *", _
"Friend Static Property Let *", _
"Property Set *", "Static Property Set *", "Private Property Set *", _
"Public Property Set *", "Friend Property Set *", _
"Private Static Property Set *", "Public Static Property Set *", _
"Friend Static Property Set *")
' ENDS LIST - ends of structures that contain lines to indent
StructureEnds = Array( _
"Loop", "Loop *", "Loop: *", _
"Next", "Next *", "Next: *", _
"End If", "End If *", "End If: *", _
"End Select", "End Select *", "End Select: *", _
"End Type", "End Type *", "End Type: *", _
"Wend", "Wend *", "Wend: *", _
"End With", "End With *", "End With: *", _
"End Sub", "End Sub *", _
"End Function", "End Function *", _
"End Property", "End Property *", "End Property: *")
' OUTDENTS LIST - exceptions that need re-aligned with respective start elements
Outdents = Array( _
"Else", "Else *", "Else: *", "Else:", _
"ElseIf * Then", "ElseIf * Then*", _
"Case", "Case *", _
"Case Else", "Case Else:", "Case Else *", "Case Else:*")
' ================================================================================
' mark array with line types - step through each line
For n = LBound(sW(), 2) To UBound(sW(), 2)
str = sW(2, n)
' mark each line if a blank
' mark each line if a blank
If Len(str) = 0 Then ' note blanks
sW(3, n) = "blank"
IsBlank = True
GoTo RoundAgain: ' comment
End If
' mark each line if an own-line comment or first of folded comment parts
IsComment = str Like Chr(39) & " *" Or str Like "' *" ' note comment lines
If IsComment Then
sW(3, n) = "comment"
GoTo RoundAgain
End If
' mark each line if a start, end, or middle
' and also if a proc start or proc end
bProc = str Like "*Sub *" Or str Like "*Function *" Or str Like "*Property *"
bEndProc = str Like "End Sub*" Or str Like "End Function*" Or str Like "End Property*"
' mark each line if a start element
For m = LBound(StructureStarts) To UBound(StructureStarts)
If sW(7, n) = "continuation" And sW(8, n) <> "" Then
IsOK = sW(8, n) Like StructureStarts(m)
Else
IsOK = str Like StructureStarts(m)
End If
If IsOK Then
sW(3, n) = "start"
If bProc Then sW(11, n) = "Proc"
Exit For
End If
Next m
If IsOK Then GoTo RoundAgain
' mark each line if an end element
For m = LBound(StructureEnds) To UBound(StructureEnds)
If sW(7, n) = "continuation" And sW(8, n) <> "" Then
IsOK = sW(8, n) Like StructureEnds(m)
Else
IsOK = str Like StructureEnds(m)
End If
If IsOK Then
sW(3, n) = "end"
If bEndProc Then sW(11, n) = "End Proc"
Exit For
End If
Next m
If IsOK Then GoTo RoundAgain
' mark each line if a middle element
For m = LBound(Outdents) To UBound(Outdents)
If sW(7, n) = "continuation" And sW(8, n) <> "" Then
IsOK = sW(8, n) Like Outdents(m)
Else
IsOK = str Like Outdents(m)
End If
If IsOK Then
sW(3, n) = "middle"
Exit For
End If
Next m
If IsOK Then GoTo RoundAgain
RoundAgain:
' reset loop variables
IsBlank = False
IsComment = False
IsContinuation = False
IsOK = False
bProc = False
bEndProc = False
Next n
End Sub
Sub MatchPairs()
' matches up the structure starts with their ends
Dim n As Long, q As Long, LB As Long, UB As Long
Dim CountStarts As Long, CountEnds As Long
Dim IsPastEnd As Boolean, IsAPair As Boolean
LB = LBound(sW(), 2): UB = UBound(sW(), 2)
' find start lines
For n = LB To UB
If sW(3, n) = "start" Then
q = n ' pass it to q for the loop
Do
If sW(3, q) = "start" Then
CountStarts = CountStarts + 1
ElseIf sW(3, q) = "end" Then
CountEnds = CountEnds + 1
End If
' exit condition is a pair found
If CountStarts = CountEnds Then ' this is match-found point
IsAPair = True
Exit Do
Else:
IsAPair = False
End If
' increment counter while accumulating
q = q + 1
' avoid access beyond upper limit of array
If q > UB Then
IsPastEnd = True
Exit Do
End If
Loop
' evaluate the loop exit causes
If IsAPair And IsPastEnd Then
' suggests that there is an unpaired structure
MsgBox "Unpaired structure for some element: " & n
ElseIf IsAPair And Not IsPastEnd Then
' found a matching structure closer for line at n
sW(4, n) = q
End If
End If
' reset loop variables
CountStarts = 0
CountEnds = 0
IsAPair = False
IsPastEnd = False
Next n
End Sub
Sub CheckPairs()
' counts structure starts and ends
' advises if code trivial or unpaired
Dim n As Long, CountStarts As Long, CountEnds As Long
Dim str As String, LB As Long, UB As Long, sM1 As String
Dim sM2 As String, Reply As String
LB = LBound(sW(), 2): UB = UBound(sW(), 2)
sM2 = "Continue with indent?" & vbNewLine & _
"Select YES to continue, or NO to exit"
' count start and end markings
For n = 1 To UB
str = sW(3, n)
If str = "start" Then CountStarts = CountStarts + 1
If str = "end" Then CountEnds = CountEnds + 1
Next n
' check for unmatched pairs and trivial text
If CountStarts > 0 And CountEnds > 0 Then
' maybe worth indenting
If CountStarts <> CountEnds Then
' possible code layout error
sM1 = "Mismatched structure pairing." & vbCrLf & _
"This will produce some indent error."
GoTo Notify
Else ' worth indenting and paired
Exit Sub
End If
Else
sM1 = "Only trivial text found" & vbCrLf & _
"No structures were found to indent."
GoTo Notify
End If
Notify:
Reply = MsgBox(sM1 & vbNewLine & sM2, vbYesNo + vbQuestion)
Select Case Reply
Case vbYes
Exit Sub
Case Else
Err.Raise 12345 ' user error
Exit Sub
End Select
End Sub
Sub Indents()
' adds indents between starts and ends
Dim n As Long, m As Long, sStr As String
For n = 1 To UBound(sW(), 2)
' get the line string
' row 3 has start markings
' corresponding row 4 has structure end number
sStr = sW(3, n)
' if string is a start element
If sStr = "start" Then
' indent all between start and end
For m = (n + 1) To sW(4, n) - 1
' indent one tab
sW(5, m) = sW(5, m) + 1
Next m
End If
Next n
End Sub
Sub Outdent()
' outdent keywords in middle of structures
Dim n As Long, Ind As Long, UB As Long
UB = UBound(sW(), 2)
' outdent loop
For n = 1 To UB
Ind = sW(5, n)
' if marked for outdent...
If sW(3, n) = "middle" Then
Ind = Ind - 1
sW(5, n) = Ind
End If
Next n
End Sub
Sub SpacePlusStr(ByVal SpacesInTab As Integer, _
Optional bKeepLineNums As Boolean = True)
' adds together line numbers, padding spaces, and
' line strings to make the indented line
' For bKeepLineNums true, line numbers kept as found,
' else false for their removal.
Dim nSPT As Long, nASC As Long, nGSC As Long, nALNL As Long
Dim p As Long, nMin As Long, nMax As Long, nTab As Long
'===============================================================
' NOTES ABOUT SPACING FOR INDENTS AND LINE NUMBERS
'===============================================================
' IN GENERAL;
' The general space count nGSC, the number of spaces
' to apply for the indent, is the prescribed number
' of tabs times the spaces-per-tab integer.
' BUT WITH LINE NUMBERS;
' For nMax < nSPT , then nASC = nGSC - nALNL
' For nMax >= nSPT, nASC = nGSC - nSPT + 1 + nMax - nALNL
' where,
' nMax is max line number length in the display set
' nSPT is the number of spaces per tab
' nASC is the number of actual spaces required as an indent
' nGSC is the general space count as described above
' nALNL is the number of digits in the current line number
'================================================================
' get the min and max lengths of any line numbers
LineNumMinMax nMax, nMin 'get min and max line numbers
' assign parameter
nSPT = SpacesInTab
' Loop through main string array
For p = 1 To UBound(sW(), 2)
nALNL = Len(sW(9, p))
' work out the general indent to apply
nTab = sW(5, p)
nGSC = nSPT * nTab 'general spaces for indent
' work out actual indent, modified for line numbers
Select Case nGSC
Case Is > 0
'for lines intended for indent at all
Select Case nMax
Case 0
nASC = nGSC
Case Is < nSPT
nASC = nGSC - nALNL
Case Is >= nSPT
nASC = nGSC - nALNL + nMax - nSPT + 1
End Select
'for lines not intended for indent
Case Is <= 0
nASC = 0
End Select
If bKeepLineNums = True Then
' combine line number, padding, and line string
sW(6, p) = sW(9, p) & Space(nASC) & sW(2, p)
Else
'combine padding and line string
sW(6, p) = Space(nGSC) & sW(2, p)
End If
Next p
End Sub
Function LineNumMinMax(max As Long, min As Long) As Boolean
'gets the minimum value of user line numbers from array
Dim n As Long
For n = LBound(sW, 2) To UBound(sW, 2)
If Len(sW(9, n)) >= max Then
max = Len(sW(9, n))
End If
If Len(sW(9, n)) <= min Then
min = Len(sW(9, n))
End If
Next n
LineNumMinMax = True
End Function
Sub MaxBlanks(sRet As String, Optional nMaxNumBlankLines As Long = 555)
' makes a single string from all code lines, indented, ready for display.
' and makes a single string from the original code lines as found.
' nMaxNumBlankLines; restricts number of contiguous blank lines.
' Values other than 0 or 1 leave blanks as found. (Default).
Dim Str2 As String, n As Long, bOK As Boolean
' accumulate original lines as one string - not used here
' For p = 1 To UBound(sW(), 2)
' Str1 = Str1 & sW(2, p) & vbNewLine
' Next p
' accumulate indented lines as one string
For n = 1 To UBound(sW(), 2)
If n = 1 And TrimStr(CStr(sW(2, n))) = "" Then
' do not accum the line
Exit For
End If
' if any line string after the first is blank
If TrimStr(CStr(sW(2, n))) = "" Then
Select Case nMaxNumBlankLines
Case 0
' do not accumulate the line
bOK = False
Case 1
' accum if only one
If TrimStr(CStr(sW(2, n - 1))) = "" Then
bOK = False
Else
bOK = True
End If
Case Else
' accumulate anyway
bOK = True
End Select
Else
' if not blank - accumulate
bOK = True
End If
If bOK Then
' accumulate line strings
Str2 = Str2 & sW(6, n) & vbNewLine ' to display indent amounts
End If
bOK = False
Next n
sRet = Left(Str2, Len(Str2) - 2)
End Sub
Function TrimStr(ByVal str As String) As String
' trims leading and lagging spaces and tabs from strings
Dim n As Long
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
TrimStr = str
End Function
Function SplitLineNums(sIn As String, sLN As String, sLS As String) As Boolean
' takes sIn and returns line number and line string parts both trimmed
' returns an empty string for any missing part.
' assumes that previous line string is not continued - handle in call proc
Dim sL As String, sS As String
Dim n As Long, sA As String, nL As Long
Dim nLS As Long, nLN As Long, bOK As Boolean
sL = Trim(sIn)
nL = Len(sL)
' if first chara numeric...
If IsNumeric(Left$(sL, 1)) Then
' separate at change to alpha
For n = 1 To nL
sS = Mid$(sL, n, 1)
' if an integer or colon...
If Asc(sS) >= 48 And Asc(sS) <= 58 Then
' accumulate...
sA = sA & sS
Else
' change point found
bOK = True
Exit For
End If
Next n
' but for numbered blank lines...
If Len(sA) = nL Then bOK = True
End If
' if a line number was found...
If bOK Then
sLN = Trim(sA)
nLN = Len(sA)
sLS = Trim(Right$(sL, nL - nLN))
nLS = Len(sLS)
Else
' if no line number was found...
sLN = "": nLN = 0: sLS = sL: nLS = nL
End If
' MsgBox sLN: MsgBox nLN: MsgBox sLS: MsgBox nLS
SplitLineNums = True
End Function
Function SplitLineParts(sIn As String, sLN As String, _
sLL As String, sS As String) As Boolean
' sIn; input is one whole vba code line string
' sLN; returns line number if used, with colon if used
' sLL; returns label string if used, always with its colon
' sSS; returns split string parts if any, lead space intact
Dim nPos As Long
' check for line number and labels
If IsLineNumbered(sIn) = True Then
sS = StrLessLineNumber(sIn, sLN) ' line number
Else
If IsLabelled(sIn) = True Then
nPos = InStr(1, sIn, ":", vbTextCompare)
sS = Right$(sIn, Len(sIn) - nPos) ' string part
sLL = Left$(sIn, nPos) ' line label
Else
sS = sIn
End If
End If
SplitLineParts = True
End Function
Function IsLineNumbered(ByVal str As String) As Boolean
' assumes test done to exclude continuation from previous line
' Returns true if str starts with a vba line number format
' Line number range is 0 to 2147483647 with or without end colon
If str Like "#*" Then
IsLineNumbered = True
End If
End Function
Function StrLessLineNumber(ByVal str As String, sLineNumber As String) As String
' assumes that possibility of number being a continuation is excluded.
' Returns with string separated from line number
' Includes any leading space
' Returns whole string if not
Dim nPos As Long, sT As String
' default transfer
StrLessLineNumber = str
' line numbers range is 0 to 2147483647
' if the line is some kind of line number line at all...
If str Like "#*" Then
' specifically, if the line uses a colon separator...
If str Like "#*: *" Then
If InStr(str, ":") Then
' get colon position
nPos = InStr(1, str, ":", vbTextCompare)
GoTo Splits
End If
End If
' specifically, if the line uses a space separator
If str Like "#* *" Then
If InStr(str, " ") Then
nPos = InStr(1, str, " ", vbTextCompare) - 1
GoTo Splits
End If
' default, if there is only a line number with nothing after...
Else
' to return a line number but empty split string...
nPos = Len(str)
GoTo Splits
End If
Splits:
' return string after separator
StrLessLineNumber = Mid(str, 1 + nPos)
sT = StrLessLineNumber
sLineNumber = Left$(str, Len(str) - Len(sT))
End If
End Function
Function IsLabelled(ByVal str As String) As Boolean
' assumes that possibility of being any kind of
' comment or a line number are first excluded
' Returns true if str starts with a vba label format
Dim nPosColon As Long, nPosSpace As Long
Dim sRC As String
' define r e m + colon
sRC = Chr(82) & Chr(101) & Chr(109) & Chr(58)
' test for single colon exception and r e m colon exception
If str Like ":*" Or str Like sRC & "*" Then Exit Function
' test position of first colon
nPosColon = InStr(1, str & ":", ":")
' test position of first space
nPosSpace = InStr(1, str & " ", " ")
IsLabelled = nPosColon < nPosSpace
End Function
' INDENT NOTES
' =====================================================================================================
' *String Array sW() row details:
' *
' * Row 1: Integers: Clipboard code line numbers.
' * Row 2: Strings: Trimmed line strings.
' * Row 3: Strings: Line type markings; one of blank, comment, start, end, or middle.
' * Row 4: Integers: Line numbers for structure ends that match start markings.
' * Row 5: Integers: Records sum of number of indents that are due for that line.
' * Row 6: Strings: Line strings with their due indents added
' * Row 7: Strings: Line type markings; continuation
' * Row 8: Strings: Joined up continuation strings as single lines
' * Row 9: Strings: User code line numbers
' * Row 10: Strings: Renumbered line numbers
' * Row 11: Strings: Proc or End Proc markings for format exceptions
' * row 12: Strings: Marked "Label" for line label
' =====================================================================================================
' * Row 3 Markings:
' *
' * "other" The most usual thing; the kind found within structures, eg a = 3*b
' * "start" The start of a closed structure; eg, Sub, If, For, Select Case, etc.
' * "end" The end of a closed structure; eg, End Sub, End If, End select, etc.
' * "middle" The keywords that display level with starts; eg, Else, Case, etc.
' * "comment" The line is a comment line with its own apostrophe at its start
' * "blank" The line is completely blank
' *====================================================================================================
' * Row 7 Continuation Marks:
' *
' * Every line that ends with a continuation mark is identified as ' continuation' as well as the start
' * and end of each continuation grouping.
' *====================================================================================================
' * Row 8 Joined line strings:
' *
' * The start and end of each continuation grouping is marked. These are used to construct a full
' * length line from the several parts of each grouping. Only then is there line type identification.
' * To see the problem, a folded comment line with ' For' or ' Do' at the start of the second line would
' * otherwise be taken as a ' start' line. So too with some other line folds.
' * Joining allows better line typing
' *=====================================================================================================