20190801OfficeVBA Indenter

Public Sub SmartIndenterProcedure()
    
    Dim StartLine As Long, EndLine As Long
    Dim LineIndex As Long
    Dim StartCol As Long, EndCol As Long
    Dim LineText As String
    Dim ProcName As String, KeyWord As String
    Dim IndentLevel As Integer, IsAfterUnderLine As Boolean
    Dim IndentThisLine As Boolean, BackThisLine As Boolean
    Dim IndentNextLine As Boolean, BackNextLine As Boolean
    
    
    Set ThisCodePane = ActiveWorkbook.VBProject.VBE.ActiveCodePane    '获取活动代码窗格
    ThisCodePane.GetSelection StartLine, StartCol, EndLine, EndCol    '获取光标位置或选定范围的 起止行列号
    
    ProcName = ActiveWorkbook.VBProject.VBE.SelectedVBComponent.CodeModule.ProcOfLine(StartLine, vbext_pk_Proc)
    StartLine = ActiveWorkbook.VBProject.VBE.SelectedVBComponent.CodeModule.ProcStartLine(ProcName, vbext_pk_Proc)
    EndLine = ActiveWorkbook.VBProject.VBE.SelectedVBComponent.CodeModule.ProcCountLines(ProcName, vbext_pk_Proc) + StartLine
    
    '循环每一行，删除行首缩进
    For LineIndex = StartLine To EndLine
        LineText = ThisCodePane.CodeModule.Lines(LineIndex, 1)
        LineText = RegReplace(LineText, "^s*")
        ThisCodePane.CodeModule.ReplaceLine LineIndex, LineText
    Next LineIndex
    
    
    '设置缩进级别
    IndentLevel = 0
    For LineIndex = StartLine To EndLine
        LineText = ThisCodePane.CodeModule.Lines(LineIndex, 1)
        KeyWord = Left(LineText, IIf(InStr(LineText, " ") = 0, Len(LineText), InStr(LineText, " ") - 1))
        
        Select Case KeyWord
        Case "Do", "For", "Private", "Public", "Select", "Sub", "While", "With", "Function", "Type", "Property"
            IndentNextLine = True                 'After certain keywords, indent next line
        Case "If"                      'After If, where line ends in Then, indent next line
            If Right(LineText, 4) = "Then" Then IndentNextLine = True
            ' If InStr(LineText, " Then ") > 0 Or InStr(LineText, " Then'") > 0 Then IndentNextLine = True
        Case "Loop", "Next", "End"                 'At Loop, Next, End, un-indent this line
            BackThisLine = True
        Case "Case", "Else", "ElseIf"
            BackThisLine = True  'Un-indent Case or Else
            IndentNextLine = True                           'Indent line after Case or Else
            'Case "Public", "Private"
            '    If Split(LineText, " ")(1) = "Sub" Or Split(LineText, " ")(1) = "Function" Then
            '       IndentNextLine = True
            '    End If
        End Select
        
        '判断续行问题
        If Right(LineText, 2) = " _" And IsAfterUnderLine = False Then
            IndentNextLine = True                             'Indent line after underscore
            IsAfterUnderLine = True      'Set a flag to un-indent the line after next
        ElseIf Right(LineText, 2) <> " _" And IsAfterUnderLine Then
            BackNextLine = True
            IsAfterUnderLine = False
        End If
        
        '处理本行的缩进级别
        If IndentThisLine Then
            IndentLevel = IndentLevel + 1
            IndentThisLine = False
        End If
        
        If BackThisLine Then
            IndentLevel = IndentLevel - 1
            BackThisLine = False
        End If
        
        On Error GoTo ErrHandler
        ThisCodePane.CodeModule.ReplaceLine LineIndex, Space$(IndentLevel * 4) & LineText
        On Error GoTo 0
        
        If IndentNextLine Then
            IndentLevel = IndentLevel + 1    '下一行的缩进级别
            IndentNextLine = False
        End If
        
        If BackNextLine Then
            IndentLevel = IndentLevel - 1    '下一行的缩进级别
            BackNextLine = False
        End If
        
    Next LineIndex
    
    Set ThisCodePane = Nothing
    
    Exit Sub
ErrHandler:
    If IndentLevel < 0 Then IndentLevel = 0  'Will not happen unless extra lines selected
    Resume Next
End Sub

Private Function RegReplace(ByVal OrgText As String, ByVal Pattern As String, Optional RepStr As String = "") As String
    Dim Regex As Object
    Dim newText As String
    Set Regex = CreateObject("VBScript.RegExp")
    With Regex
        .Global = True
        .Pattern = Pattern
    End With
    newText = Regex.Replace(OrgText, RepStr)
    RegReplace = newText
    Set Regex = Nothing
End Function