Uz Galaxy - Info Archive top BBS   RSS
Info Archive  Info Archive開発 - 17 VBのソースコードをカラフルなHTML形式に変換  

ソースコードを色つきにきれいな状態で公開したいので、以下の関数を使ってHTML形式に変換する。
※このページのコードはその関数を使って変換したものです。

 
Module VBtoHTMLLib
    Public Function VBtoHTML_LineNo(ByVal sText As String) As String
        Dim sHtml As String = VBtoHTML(sText, False)

        Do
            If sHtml.Substring(sHtml.Length - 2, 2) = vbCrLf Then
                sHtml = sHtml.Substring(0, sHtml.Length - 2)
            Else
                Exit Do
            End If
        Loop

        Dim nPos As Integer = 0
        Dim nLineCnt As Integer = 0
        Do
            nPos = sHtml.IndexOf(vbCrLf, nPos) + 1
            If nPos = 0 Then Exit Do
            nLineCnt += 1
        Loop

        Dim I As Integer
        Dim sLineNo As String = ""

        For I = 0 To nLineCnt
            sLineNo += vbCrLf & Format(I + 1, "0000")
        Next
        sLineNo += vbCrLf

        sHtml = "<table valing='top'><tr valign='top'><td bgcolor='gainsboro'><pre style='margin=0px'>" & _
                sLineNo & "</pre></td><td>&nbsp;</td><td><pre style='margin=0px'>" & sHtml & "</pre></td></tr></table>"
        Return sHtml
    End Function

    '
    ' VB のソースコードを HTML に変換する
    '
    Public Function VBtoHTML(ByVal sText As String, Optional ByVal bPreTag As Boolean = True) As String
        If sText.Length = 0 Then Return ""

        sText = sText.Replace(vbCrLf, vbCr)
        sText = sText.Replace(vbLf, vbCr)

        Dim sHtml As String = ""
        Dim sWord As String = ""
        Dim bString As Boolean
        Dim bComment As Boolean

        Dim sReserved() As String = {"AddHandler", "AddressOf", "Alias", "And", "AndAlso", "Ansi", "As", "Assembly", _
                                    "Auto", "Boolean", "ByRef", "Byte", "ByVal", "Call", "Case", "Catch", "CBool", _
                                    "CByte", "CChar", "CDate", "CDec", "CDbl", "Char", "CInt", "Class", "CLng", "CObj", _
                                    "Const", "CShort", "CSng", "CStr", "CType", "Date", "Decimal", "Declare", "Default", _
                                    "Delegate", "Dim", "DirectCast", "Do", "Double", "Each", "Else", "ElseIf", "End", _
                                    "Enum", "Erase", "Error", "Event", "Exit", "False", "Finally", "For", "Friend", _
                                    "Function", "Get", "GetType", "GoSub", "GoTo", "Handles", "If", "Implements", _
                                    "Imports", "In", "Inherits", "Integer", "Interface", "Is", "Let", "Lib", "Like", _
                                    "Long", "Loop", "Me", "Mod", "Module", "MustInherit", "MustOverride", "MyBase", _
                                    "MyClass", "Namespace", "New", "Next", "Not", "Nothing", "NotInheritable", _
                                    "NotOverridable", "Object", "On", "Option", "Optional", "Or", "OrElse", _
                                    "Overloads", "Overridable", "Overrides", "ParamArray", "Preserve", "Private", _
                                    "Property", "Protected", "Public", "RaiseEvent", "ReadOnly", "ReDim", "REM", _
                                    "RemoveHandler", "Resume", "Return", "Select", "Set", "Shadows", "Shared", "Short", _
                                    "Single", "Static", "Step", "Stop", "String", "Structure", "Sub", "SyncLock", "Then", _
                                    "Throw", "To", "True", "Try", "TypeOf", "Unicode", "Until", "Variant", "When", "While", _
                                    "With", "WithEvents", "WriteOnly", "Xor", "#Const", "#ExternalSource", "#If", "Then", _
                                    "#Else", "#End If", "#Region", "#End Region", "-", "&amp;", "&amp;=", "*", "*=", "/", _
                                    "/=", "\", "\=", "^", "^=", "+", "+=", "=", "-="}

        Dim I As Integer

        bString = False
        bComment = False

        sText += " "

        Dim sCrLf As String = IIf(bPreTag, vbCrLf, "<br />")

        Dim c As String
        While sText.Length() > 0
            c = sText.Substring(0, 1)
            sText = sText.Substring(1)

            If bComment Then
                Select Case c
                    Case vbCr
                        sWord = "<font color='green'>" & sWord & "</font>" & sCrLf
                        bComment = False

                        sHtml += sWord
                        sWord = ""
                        c = ""
                    Case "<"
                        c = "&lt;"
                    Case ">"
                        c = "&gt;"
                    Case "&"
                        c = "&amp;"
                    Case " "
                        If Not bPreTag Then
                            c = "&nbsp;"
                        End If
                End Select
                sWord += c
            Else

                Select Case c
                    Case " ", vbCr, "(", ")", ","
                        If Not bPreTag AndAlso c = " " Then
                            c = "&nbsp;"
                        End If

                        If bComment Then
                            If c = vbCr Then
                                sWord = "<font color='green'>" & sWord & "</font>" & sCrLf
                                bComment = False

                                sHtml += sWord
                                sWord = ""
                                c = ""
                            End If
                        End If

                        If Not bString Then
                            If sWord.ToLower() = "#end" Then

                            Else

                                For I = 0 To UBound(sReserved)
                                    If sWord.ToLower() = sReserved(I).ToLower() Then
                                        sWord = "<font color='blue'>" & sReserved(I) & "</font>"
                                        Exit For
                                    End If
                                Next

                                sHtml += sWord
                                sWord = ""

                                Select Case c
                                    Case vbCr
                                        c = sCrLf
                                End Select
                                sHtml += c
                                c = ""
                            End If
                        End If

                    Case "'"
                        If Not bString Then
                            bComment = True
                        End If

                    Case """"
                        If bString Then
                            If sText.Substring(0, 1) = """" Then
                                sWord += c + """"
                                sText = sText.Substring(1)
                            Else
                                sWord += c
                                sWord = "<font color='teal'>" & sWord & "</font>"
                                sHtml += sWord
                                sWord = ""
                                bString = False
                            End If
                        Else
                            sHtml += sWord

                            sWord = c
                            bString = True
                        End If
                        c = ""

                    Case "<"
                        c = "&lt;"
                    Case ">"
                        c = "&gt;"
                    Case "&"
                        c = "&amp;"
                    Case " "
                        If Not bPreTag Then
                            c = "&nbsp;"
                        End If

                    Case Else

                End Select

                sWord += c
            End If
        End While

        sHtml = sHtml.Substring(0, sHtml.Length - 1)
        If bPreTag Then
            sHtml = "<pre>" & sHtml & "</pre>" & vbCrLf
        End If

        Return sHtml
    End Function
End Module

※ 末尾に予約語があると、その単語が出力されていなかったのを修正。 2004/08/04
※ コメント内に < > & がある場合、変換するように修正。 2004/08/06
※ 行番号つきの関数を作成。 2004/08/06
※ 予約語の後に , (カンマ) があると色がつかなかったのを修正。 2004/08/07
※ str = "aaa""""aaa" というようなものが正しく変換できなかったのを修正。 2004/08/28


Copyright © 2004 Uz. All rights reserved.
http://uzgalaxy.com/
このページはInfoArchiveで作成されています。