Excelシート上でVBAコードのシンタックスハイライト

#初めに
仕事でVBAのソースコードを読む必要が出てきたので、過去に作成したVBA用のシンタックスハイライトマクロを若干変更を加えて投稿する。

#使い方
1. Excelシート上にソースコードを貼り付ける (*1)
2. 「シンタックスハイライト」マクロを実行する

*1
ソースコード1行分を1セル(1行1列)に貼り付けること。
例えば、100行分のソースコードの場合は100行1列に貼り付ける。

#注意事項
・十分にテストしていません
・キーワードのハイライトはとくに注意

#ソースコード
```vb:SyntaxHighlightForVBA.bas
Option Explicit

Sub シンタックスハイライト()

    If Selection Is Nothing Then
        Call MsgBox("対象のセル範囲を選択して下さい。", vbExclamation Or vbOKOnly)
        Exit Sub
    End If

    If Not TypeOf Selection Is Range Then
        Call MsgBox("対象のセル範囲を選択して下さい。", vbExclamation Or vbOKOnly)
        Exit Sub
    End If

    Call SyntaxHighlightForVBA(Selection)

    Call MsgBox("処理が完了しました。", vbInformation Or vbOKOnly)

End Sub

Private Sub SyntaxHighlightForVBA(TargetRange As Range)

    Dim Area As Range
    Dim Cell As Range
    Dim CharCount As Long
    Dim CharIndex As Long
    Dim Char As String
    Dim NextChar As String
    Dim StartIndexOfComment As Long
    Dim EndIndexOfComment As Long
    Dim StartIndexOfStringLiteral As Long
    Dim EndIndexOfStringLiteral As Long
    Dim StartIndexOfToken As Long
    Dim EndIndexOfToken As Long

    For Each Area In TargetRange.Areas
        For Each Cell In Area.Cells

            CharIndex = 1
            CharCount = Cell.Characters.Count

            StartIndexOfComment = 0
            EndIndexOfComment = 0
            StartIndexOfStringLiteral = 0
            EndIndexOfStringLiteral = 0
            StartIndexOfToken = 0
            EndIndexOfToken = 0

            Do While CharIndex <= CharCount

                If StartIndexOfComment > 0 Then

                    '***** コメント中 *****
                    EndIndexOfComment = CharIndex

                ElseIf StartIndexOfStringLiteral > 0 Then

                    '***** 文字列リテラル *****
                    Char = Cell.Characters(CharIndex, 1).Text

                    If Char = """" Then
                        If CharIndex + 1 <= CharCount Then
                            NextChar = Cell.Characters(CharIndex + 1, 1).Text
                            If NextChar = """" Then
                                CharIndex = CharIndex + 1
                                EndIndexOfStringLiteral = CharIndex
                            Else
                                EndIndexOfStringLiteral = CharIndex
                                Call HighlightStringLiteral(Cell, StartIndexOfStringLiteral, EndIndexOfStringLiteral)
                                StartIndexOfStringLiteral = 0
                                EndIndexOfStringLiteral = 0
                            End If
                        Else
                            EndIndexOfStringLiteral = CharIndex
                            Call HighlightStringLiteral(Cell, StartIndexOfStringLiteral, EndIndexOfStringLiteral)
                            StartIndexOfStringLiteral = 0
                            EndIndexOfStringLiteral = 0
                        End If
                    Else
                        EndIndexOfStringLiteral = CharIndex
                    End If

                Else

                    Char = Cell.Characters(CharIndex, 1).Text
                    Select Case Char

                    Case "'"

                        If StartIndexOfToken > 0 Then
                            Call HighlightToken(Cell, StartIndexOfToken, EndIndexOfToken)
                            StartIndexOfToken = 0
                            EndIndexOfToken = 0
                        Else
                            StartIndexOfComment = CharIndex
                            EndIndexOfComment = CharIndex
                        End If

                    Case """"

                        If StartIndexOfToken > 0 Then
                            Call HighlightToken(Cell, StartIndexOfToken, EndIndexOfToken)
                            StartIndexOfToken = 0
                            EndIndexOfToken = 0
                        Else
                            StartIndexOfStringLiteral = CharIndex
                            EndIndexOfStringLiteral = CharIndex
                        End If

                    Case vbTab, " ", "!", "#", "$", "%", "&", "(", ")", "*", _
                         "+", ",", "-", ".", "/", ":", ";", "<", "=", ">", _
                         "?", "@", "[", "\", "]", "^", "`", "{", "|", "}", "~"

                        If StartIndexOfToken > 0 Then
                            Call HighlightToken(Cell, StartIndexOfToken, EndIndexOfToken)
                            StartIndexOfToken = 0
                            EndIndexOfToken = 0
                        End If

                    Case Else

                        If StartIndexOfToken > 0 Then
                            EndIndexOfToken = CharIndex
                        Else
                            StartIndexOfToken = CharIndex
                            EndIndexOfToken = CharIndex
                        End If

                    End Select
                End If

                CharIndex = CharIndex + 1
            Loop

            If StartIndexOfComment > 0 Then
                Call HighlightComment(Cell, StartIndexOfComment, EndIndexOfComment)
            ElseIf StartIndexOfStringLiteral > 0 Then
                Debug.Assert False
            ElseIf StartIndexOfToken > 0 Then
                Call HighlightToken(Cell, StartIndexOfToken, EndIndexOfToken)
            End If
        Next
    Next

End Sub

Private Sub HighlightComment(Cell As Range, StartIndex As Long, EndIndex As Long)

    Cell.Characters(StartIndex, EndIndex - StartIndex + 1).Font.Color = RGB(0, 128, 0)

End Sub

Private Sub HighlightStringLiteral(Cell As Range, StartIndex As Long, EndIndex As Long)

    '文字列リテラルをハイライトしたい場合は次のコメントを外して色を設定する
    'Cell.Characters(StartIndex, EndIndex - StartIndex + 1).Font.Color = RGB(255, 0, 0)

End Sub

Private Sub HighlightToken(Cell As Range, StartIndex As Long, EndIndex As Long)

    Dim Token As String

    Token = Cell.Characters(StartIndex, EndIndex - StartIndex + 1).Text
    If IsKeyword(Token) Then
        Cell.Characters(StartIndex, EndIndex - StartIndex + 1).Font.Color = RGB(0, 0, 255)
    End If

End Sub

Private Function IsKeyword(Token As String) As Boolean

    'キーワード
    Const KEYWORD_LIST = _
        "ADDRESSOF,ALIAS,AND,APPEND,ARRAY,AS,ATTRIBUTE,BEGIN,BEGINPROPERTY," & _
        "BOOLEAN,BYREF,BYTE,BYVAL,CALL,CASE,CONST,CURRENCY,DATE,DECLARE," & _
        "DEFBOOL,DEFBYTE,DEFCUR,DEFDATE,DEFDBL,DEFDEC,DEFINT,DEFLNG,DEFLNGLNG," & _
        "DEFLNGPTR,DEFOBJ,DEFSNG,DEFSTR,DEFVAR,DIM,DO,DOUBLE,EACH,ELSE,ELSEIF," & _
        "EMPTY,END,ENDPROPERTY,ENUM,EQV,ERASE,ERROR,EXIT,EXPLICIT,FALSE,FOR," & _
        "FRIEND,FUNCTION,GET,GLOBAL,GOSUB,GOTO,IF,IMP,IMPLEMENTS,IN,INTEGER," & _
        "IS,LET,LIB,LIKE,LONG,LOOP,LSET,ME,MOD,NEW,NEXT,NOT,NOTHING,NULL," & _
        "OBJECT,ON,OPTION,OPTIONAL,OR,OUTPUT,PRIVATE,PROPERTY,PUBLIC,REDIM," & _
        "REM,RESUME,RETURN,RSET,SELECT,SET,SINGLE,STATIC,STEP,STOP,STRING,SUB," & _
        "TERMINATE,THEN,TO,TRUE,TYPE,TYPEOF,UNTIL,VARIANT,WEND,WHILE,WITH,XOR"

    Static KeywordDictionary As Object
    Dim Keywords, Index As Long

    If KeywordDictionary Is Nothing Then
        Set KeywordDictionary = CreateObject("Scripting.Dictionary")
        Keywords = Split(KEYWORD_LIST, ",")
        For Index = LBound(Keywords) To UBound(Keywords)
            Call KeywordDictionary.Add(Keywords(Index), 1)
        Next
    End If

    IsKeyword = KeywordDictionary.Exists(UCase(Token))

End Function

```