#初めに
仕事でVBAのソースコードを読む必要が出てきたので、過去に作成したVBA用のシンタックスハイライトマクロを若干変更を加えて投稿する。
#使い方
- Excelシート上にソースコードを貼り付ける (*1)
- 「シンタックスハイライト」マクロを実行する
*1
ソースコード1行分を1セル(1行1列)に貼り付けること。
例えば、100行分のソースコードの場合は100行1列に貼り付ける。
#注意事項
・十分にテストしていません
・キーワードのハイライトはとくに注意
#ソースコード
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