Option Explicit
'这一版基本可以实现vb6的代码自动缩进和删除多个空行为一个空行的目的。
'有什么问题可以将原代码和测试片段和效果片段一起发给豆包解决。
'提取本行有效代码，剔除字符串、注释内容
Private Function ExtractEffectiveCode(ByVal line As String) As String
Dim i As Long
Dim inString As Boolean
Dim char As String
Dim result As String
inString = False
result = ""
For i = 1 To Len(line)
char = Mid(line, i, 1)
If char = "'" And Not inString Then
Exit For
End If
If char = """" Then
inString = Not inString
End If
If Not inString Then
result = result & char
End If
Next i
ExtractEffectiveCode = Trim(result)
End Function
'判断是否 Else / ElseIf
Private Function IsElseBlock(ByVal codeBody As String) As Boolean
Dim t As String
t = Trim(UCase(codeBody))
IsElseBlock = (t = "ELSE") Or (t Like "ELSEIF *")
End Function
'判断是否 Case / Case Else
Private Function IsCaseBlock(ByVal codeBody As String) As Boolean
Dim t As String
t = Trim(UCase(codeBody))
IsCaseBlock = False
If t Like "CASE*" Then IsCaseBlock = True
End Function
'判断是否 Sub 过程声明
Private Function IsSubStart(ByVal codeBody As String) As Boolean
Dim t As String
t = Trim(UCase(codeBody))
IsSubStart = t Like "SUB *"
End Function
'判断是否 Function 函数声明
Private Function IsFunctionStart(ByVal codeBody As String) As Boolean
Dim t As String
t = Trim(UCase(codeBody))
IsFunctionStart = t Like "FUNCTION *"
End Function
'判断是否单行If（不开启块）
Private Function IsSingleLineIf(ByVal codeBody As String) As Boolean
Dim t As String
t = Trim(UCase(codeBody))
If Not t Like "IF *THEN*" Then
IsSingleLineIf = False
Exit Function
End If
Dim posThen As Long
posThen = InStr(UCase(t), "THEN")
If posThen <= 0 Then
IsSingleLineIf = False
Exit Function
End If
Dim afterThen As String
afterThen = Trim(Mid(t, posThen + 4))
IsSingleLineIf = (Len(afterThen) > 0)
End Function
'判断本行是否以续行符结尾
Private Function HasLineContinuation(ByVal rawLine As String) As Boolean
Dim pureCode As String
pureCode = ExtractEffectiveCode(rawLine)
pureCode = RTrim(pureCode)
If Len(pureCode) = 0 Then
HasLineContinuation = False
Else
HasLineContinuation = (Right(pureCode, 1) = "_")
End If
End Function
'核心缩进处理函数
Private Function SimpleIndent(ByVal sourceText As String) As String
Dim lines() As String
Dim outLines() As String
Dim idx As Long
Dim indentLevel As Long
Dim rawLine As String
Dim codeBody As String
Dim indentSpace As String
Dim isContinuedLine As Boolean
'标记变量
Dim isSubStartLine As Boolean
Dim isFuncStartLine As Boolean
Dim isSelectStartLine As Boolean
Dim isCaseLine As Boolean
Dim isElseLine As Boolean
Dim isEndSub As Boolean
Dim isEndFunc As Boolean
Dim isEndSelect As Boolean
Dim isEndIf As Boolean
Dim isNext As Boolean
Dim isLoop As Boolean
Dim isMultiIfStart As Boolean
Dim isForStart As Boolean
Dim isDoStart As Boolean
Dim isWhileStart As Boolean
lines = Split(sourceText, vbCrLf)
ReDim outLines(UBound(lines))
indentLevel = 0
isContinuedLine = False
For idx = LBound(lines) To UBound(lines)
rawLine = lines(idx)
rawLine = TrimStart(rawLine)
codeBody = ExtractEffectiveCode(rawLine)
'重置全部标记
isSubStartLine = False
isFuncStartLine = False
isSelectStartLine = False
isCaseLine = False
isElseLine = False
isEndSub = False
isEndFunc = False
isEndSelect = False
isEndIf = False
isNext = False
isLoop = False
isMultiIfStart = False
isForStart = False
isDoStart = False
isWhileStart = False
'识别本行类型
If IsSubStart(codeBody) Then isSubStartLine = True
If IsFunctionStart(codeBody) Then isFuncStartLine = True
If Trim(UCase(codeBody)) Like "SELECT CASE*" Then isSelectStartLine = True
If IsCaseBlock(codeBody) Then isCaseLine = True
If IsElseBlock(codeBody) Then isElseLine = True
Dim ut As String
ut = Trim(UCase(codeBody))
If ut Like "END SUB" Then isEndSub = True
If ut Like "END FUNCTION" Then isEndFunc = True
If ut Like "END SELECT" Then isEndSelect = True
If ut Like "END IF" Then isEndIf = True
If ut Like "NEXT*" Then isNext = True
If ut Like "LOOP*" Then isLoop = True
If ut Like "FOR *" Then isForStart = True
If ut Like "DO*" Then isDoStart = True
If ut Like "WHILE*" Then isWhileStart = True
If ut Like "IF *THEN*" And Not IsSingleLineIf(codeBody) Then isMultiIfStart = True
'========== 步骤1：块结束 / Else / Case，输出前先回退缩进 ==========
If Not isContinuedLine Then
If isEndSub Or isEndFunc Or isEndSelect Or isEndIf Or isNext Or isLoop Or isElseLine Or isCaseLine Then
If indentLevel >= 4 Then
indentLevel = indentLevel - 4
End If
End If
End If
'========== 步骤2：生成缩进，输出本行 ==========
indentSpace = String(indentLevel, " ")
If Trim(rawLine) = "" Then
outLines(idx) = ""
Else
outLines(idx) = indentSpace & rawLine
End If
'========== 步骤3：本行输出完成后，块开始/分支，增加下一行缩进 ==========
If Not isContinuedLine Then
'块开始：Sub / Function / SelectCase / For / Do / While /多行If
If isSubStartLine Or isFuncStartLine Or isSelectStartLine Or isMultiIfStart Or isForStart Or isDoStart Or isWhileStart Then
indentLevel = indentLevel + 4
End If
'分支：Else、Case，输出完本行后，内部代码缩进
If isElseLine Or isCaseLine Then
indentLevel = indentLevel + 4
End If
End If
'========== 步骤4：更新续行标记 ==========
isContinuedLine = HasLineContinuation(rawLine)
Next idx
SimpleIndent = Join(outLines, vbCrLf)
End Function
'压缩连续空行，多个空行只保留一行
Private Function CompactBlankLines(ByVal sourceText As String) As String
Dim lines() As String
Dim outList As New Collection
Dim idx As Long
Dim line As String
Dim lastWasBlank As Boolean
lines = Split(sourceText, vbCrLf)
lastWasBlank = False
For idx = LBound(lines) To UBound(lines)
line = lines(idx)
If Trim(line) = "" Then
If Not lastWasBlank Then
outList.Add line
lastWasBlank = True
End If
Else
outList.Add line
lastWasBlank = False
End If
Next idx
Dim resultArr() As String
ReDim resultArr(1 To outList.Count)
For idx = 1 To outList.Count
resultArr(idx) = outList(idx)
Next idx
CompactBlankLines = Join(resultArr, vbCrLf)
End Function
'=====窗体调用示例=====
Private Sub Command1_Click()
Dim src As String
Dim strCompact As String
Dim strIndent As String
src = Text1.Text
strCompact = CompactBlankLines(src)
strIndent = SimpleIndent(strCompact)
Text2.Text = strIndent
End Sub
'移除一行文本开头的空格、Tab，中间和末尾保留原样
Private Function TrimStart(ByVal s As String) As String
Dim i As Long
For i = 1 To Len(s)
Dim c As String
c = Mid(s, i, 1)
If c <> " " And c <> vbTab Then
TrimStart = Mid(s, i)
Exit Function
End If
Next i
'整行都是空白，返回空
TrimStart = ""
End Function
