Convert VB source code to html.

First of all, in making this blog, I wrote the VBA code for converting the VBA code to HTML code.
I think there is already similar freeware on the net, but I like writing VBA code, so I dared to do this myself.

After copying the VBA code to the clipboard, execute the following code to convert the clipboard contents to HTML.
At that time, the comment and the character string are colored.

For example
VBA code
  If s <> "A" Then 'Sample

   ->HTML code
  If&nbsp;s&nbsp;&lt;&gt;&nbsp;<font color = #ff0000>"A"</font>&nbsp;Then&nbsp;<font color = #0000ff>'Sample</font>

   ->Display in browser
  If s <> "A" Then 'Sample

---

Option Explicit

Sub Main()
    
    'When using early binding that references Microsoft Forms 2.0 Object Library
    'Dim Clip As DataObject
    'Set Clip = New DataObject
    
    'When using late binding that references the Microsoft Forms 2.0 Object Library
    Dim Clip As Object
    Set Clip = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
    Dim sOriginal As String
    Dim sCurrent As String
    Dim sHtml As String
    
    Clip.GetFromClipboard
    sOriginal = Clip.GetText
    sHtml = ConvertBasicSourceToHtm(sOriginal)
    
    Clip.SetText sHtml
    Clip.PutInClipboard

    Set Clip = Nothing

End Sub

Function ConvertBasicSourceToHtm(ByRef sOriginal As String) As String
                
    ConvertBasicSourceToHtm = ""
    Dim i As Long
    Dim sCurrent As String
    Dim lLen As Long
    
    Const csFontTagForQuotedString As String = "<font color = #ff0000>" 'Red
    Const csFontTagForComment As String = "<font color = #0000ff>" 'Blue
    
    Const csFontTagEnd As String = "</font>"
    
    For i = 1 To Len(sOriginal)
        sCurrent = Mid(sOriginal, i, 1)
        
        'Characters enclosed in double quotations are highlighted in red
        If sCurrent = """" Then
            
            Concat ConvertBasicSourceToHtm, csFontTagForQuotedString, lLen
            Concat ConvertBasicSourceToHtm, ReplaceMarks(sCurrent), lLen
            
            i = i + 1
            sCurrent = ""
            Do
                sCurrent = Mid(sOriginal, i, 1)
                
                Concat ConvertBasicSourceToHtm, ReplaceMarks(sCurrent), lLen
                
                If sCurrent = """" Then
                    If Mid(sOriginal, i + 1, 1) <> """" Then
                        Exit Do
                    End If
                    
                ElseIf sCurrent = vbCr Then
                    Exit Do
                
                ElseIf sCurrent = vbLf Then
                    Exit Do
                
                ElseIf sCurrent = "" Then
                    Exit Do
                End If
                i = i + 1
            Loop
            
            Concat ConvertBasicSourceToHtm, csFontTagEnd, lLen
            
        'Comments starting with a single quotation are highlighted in blue.
        'Unfortunately, it does not support comments from Rem statements.
        ElseIf sCurrent = "'" Then
            
            Concat ConvertBasicSourceToHtm, csFontTagForComment, lLen
            Concat ConvertBasicSourceToHtm, ReplaceMarks(sCurrent), lLen
            
            i = i + 1
            sCurrent = ""
            Do
                sCurrent = Mid(sOriginal, i, 1)
                
                Concat ConvertBasicSourceToHtm, ReplaceMarks(sCurrent), lLen
                
                If sCurrent = vbCr Then
                    Exit Do
                ElseIf sCurrent = vbLf Then
                    Exit Do
                ElseIf sCurrent = "" Then
                    Exit Do
                End If
                i = i + 1
            Loop
            
            Concat ConvertBasicSourceToHtm, csFontTagEnd, lLen
            
        Else
        
            'If it is neither a comment nor a string, simply replace the special symbols.
            Concat ConvertBasicSourceToHtm, ReplaceMarks(sCurrent), lLen
        End If
    Next

    ConvertBasicSourceToHtm = Left(ConvertBasicSourceToHtm, lLen)

End Function

Sub Concat(ByRef sAll As String, ByRef sPart As String, ByRef lTotalLength As Long)
    
    ' String concatenation of long strings with & is extremely slow,
    ' so you should use such logic if you frequently concatenate strings of long strings.
    
    Dim lPartLength
    lPartLength = Len(sPart)
    
    If lPartLength = 0 Then
      Exit Sub
    End If
    
    ' Allocate memory redundantly because it takes the longest to allocate memory.
    ' Reallocate memory when it runs out of allocated memory.
    
    If lTotalLength + lPartLength > Len(sAll) Then
        sAll = sAll & Space(1000)
    End If
    
    Mid(sAll, lTotalLength + 1, lPartLength) = sPart
    lTotalLength = lTotalLength + lPartLength
    
End Sub


Function ReplaceMarks(ByRef sOriginal As String) As String
    Select Case sOriginal
            Case "<"
                ReplaceMarks = "&lt;"
            
            Case ">"
                ReplaceMarks = "&gt;"
            
            Case " "
                ReplaceMarks = "&nbsp;"
            
            Case "&"
                ReplaceMarks = "&amp;"
            
            Case vbCr
                 ReplaceMarks = ""
            
            Case vbLf
                ReplaceMarks = "<br>" & vbCrLf
            
            Case Else
                ReplaceMarks = sOriginal
    End Select
End Function

---