如何用vba代码实现vba代码的缩进排列？

楼主
kevinchengcw

Q: 如何用vba代码实现vba代码的缩进排列？
A: 代码如下：

Sub ArrangeCode()
Dim Arr, Arr2, N&, T%, Str$, Dic, Result$
Set Dic = CreateObject("scripting.dictionary") '创建字典项目，用于存储规则
With Dic '添加不同关键字对代码缩进带来的影响，key为关键字，item为影响值（规则：对本行的影响值|对下一行的影响值）
.Add "if", "0|1"
.Add "else", "-1|1"
.Add "else:", "-1|1"
.Add "elseif", "-1|1"
.Add "end if", "-1|0"
.Add "with", "0|1"
.Add "end with", "-1|0"
.Add "for", "0|1"
.Add "next", "-1|0"
.Add "do", "0|1"
.Add "loop", "-1|0"
.Add "select", "0|1"
.Add "case", "-1|1"
.Add "end select", "-1|0"
End With
With CreateObject("vbscript.regexp") '创建正则项目，用于整理代码中的空白行（在其他帖子里有讲解，本例不做详述）
.Global = True
.MultiLine = True
.Pattern = "(\n[\'\s]*)(\n)"
Str = .Replace(MainWindow.TextBox1.Text, "$2")
Str = Replace(Str, vbNewLine & "End Sub" & vbNewLine, vbNewLine & "End Sub" & vbNewLine & vbNewLine)
.Pattern = "(\n)[ " & Chr(9) & "]+" '利用正则替换掉代码前面全部的制表符及空格
Str = .Replace(Str, "$1")
End With
Arr = Split(Str, vbNewLine) '以换行标记分割，将代码放到数组中
T = 0 '初始化最初的代码缩进量
For N = LBound(Arr) To UBound(Arr) '循环各段代码
If N = LBound(Arr) Then '如果是第一行，则直接等于原来代码，不做改变
Result = Arr(N)
Else '如果是其他行，则进行相关判断
If Trim(Arr(N)) <> "" Then '如果不是空白行，则
If LCase(Trim(Arr(N))) = "end sub" Or LCase(Trim(Arr(N))) = "end function" Then '判断是否是程序结尾，如果是，则缩进量清零，直接串接本段代码
T = 0
Result = Result & vbNewLine & Arr(N)
ElseIf LCase(Trim(Arr(N))) Like "if * then *" Then '否则如果是if...then...结构，且then后面有代码，则保持现在的缩进量
Result = Result & vbNewLine & WorksheetFunction.Rept(vbTab, T) & Arr(N)
ElseIf Dic.exists(LCase(Trim(Arr(N)))) Then '否则如果存在该字典项，则判断缩进量变化后是否会小于0，小于0则为0，否则为变化后的量，并串接当前缩进量数量的制表符（利用工作表函数rept完成该动作，分别处理本行及下一行的缩进量）
If T + Val(Split(Dic(LCase(Trim(Arr(N)))), "|")(0)) >= 0 Then T = T + Val(Split(Dic(LCase(Trim(Arr(N)))), "|")(0))
Result = Result & vbNewLine & WorksheetFunction.Rept(vbTab, T) & Arr(N)
If T + Val(Split(Dic(LCase(Trim(Arr(N)))), "|")(1)) >= 0 Then T = T + Val(Split(Dic(LCase(Trim(Arr(N)))), "|")(1))
Else '如果以上情况都不成立，则继续依空格拆分当前代码行放入数组，判断遇到的情况并予以处理
Arr2 = Split(Trim(Arr(N)), " ")
If UBound(Arr2) > 0 Then
If LCase(Arr2(0)) = "end" And Dic.exists(LCase(Arr2(0)) & " " & LCase(Arr2(1))) Then
If T + Val(Split(Dic(LCase(Arr2(0)) & " " & LCase(Arr2(1))), "|")(0)) >= 0 Then T = T + Val(Split(Dic(LCase(Arr2(0)) & " " & LCase(Arr2(1))), "|")(0))
Result = Result & vbNewLine & WorksheetFunction.Rept(vbTab, T) & Arr(N)
If T + Val(Split(Dic(LCase(Arr2(0)) & " " & LCase(Arr2(1))), "|")(1)) >= 0 Then T = T + Val(Split(Dic(LCase(Arr2(0)) & " " & LCase(Arr2(1))), "|")(1))
ElseIf Dic.exists(LCase(Arr2(0))) Then
If T + Val(Split(Dic(LCase(Arr2(0))), "|")(0)) >= 0 Then T = T + Val(Split(Dic(LCase(Arr2(0))), "|")(0))
Result = Result & vbNewLine & WorksheetFunction.Rept(vbTab, T) & Arr(N)
If T + Val(Split(Dic(LCase(Arr2(0))), "|")(1)) >= 0 Then T = T + Val(Split(Dic(LCase(Arr2(0))), "|")(1))
Else
Result = Result & vbNewLine & WorksheetFunction.Rept(vbTab, T) & Arr(N)
End If
Else
Result = Result & vbNewLine & WorksheetFunction.Rept(vbTab, T) & Arr(N)
End If
End If
Else
Result = Result & vbNewLine & Arr(N)
End If
End If
Next N
MainWindow.TextBox1.Text = Result '显示处理后的结果
Set Dic = Nothing '清空字典项目
End Sub

相关内容已集成到"VBA解释器_进化5"中，可以到下面地址下载，以上为其中代码解读。
http://www.exceltip.net/thread-6986-1-1.html

2楼
hhzjxss

谢谢版主，感谢分享，学习一下先！