optionexplicit.txt

VB源程序转换成HTML文件 一个简单的东西大家看看吧

Option Explicit

Private SelectedColor As Integer
' Put bold delimiters around comments.
Private Function BoldComments(ByVal txt As String) As String
Dim pos As Integer
Dim ch As String
Dim quote_open As Boolean

    ' Find the first ' not inside quotes.
    For pos = 1 To Len(txt)
        ch = Mid$(txt, pos, 1)
        If ch = """" Then
            quote_open = Not quote_open
        ElseIf (ch = "'") And (Not quote_open) Then
            ' We found it. Stop here.
            Exit For
        End If
    Next pos

    If pos <= Len(txt) Then
        ' We have a comment.
        BoldComments = Left$(txt, pos - 1) & _
            "'" & Mid$(txt, pos + 1) & ""
    Else
        ' We have no comment.
        BoldComments = txt
    End If
End Function

' Replace from_str with to_str.
Private Function ReplaceString(ByVal txt As String, ByVal from_str As String, ByVal to_str As String) As String
Dim result As String
Dim pos As Integer

    result = ""
    Do
        pos = InStr(txt, from_str)
        If pos = 0 Then Exit Do

        result = result & _
            Left$(txt, pos - 1) & _
            to_str
        txt = Mid$(txt, pos + Len(from_str))
    Loop

    result = result & txt
    ReplaceString = result
End Function

' Build an HTML table representing source code.
Private Function SourceToHTML(ByVal source_text As String) As String
Dim bg_color As String
Dim txt As String
Dim pos As Integer
Dim next_line As String

    txt = ""
   
    ' Compute the selected color.
    If SelectedColor = 0 Then
        bg_color = ""
    Else
        bg_color = Hex$(picColor(SelectedColor).BackColor)
    End If

    ' If the background color is not blank,
    ' use a table.
    If Len(bg_color) > 0 Then
        ' Start the table.
        txt = txt & "<TABLE BORDER=1 CELLSPACING=0 CELLPADDING=2 BGCOLOR=#" & bg_color & ">" & vbCrLf
        txt = txt & "<TR><TD>" & vbCrLf
    End If

    ' Start TT PRE.
    txt = txt & "<TT><PRE>"

    Do While Len(source_text) > 0
        ' Get the next line.
        pos = InStr(source_text, vbCrLf)
        If pos = 0 Then
            next_line = source_text
            source_text = ""
        Else
            next_line = Left$(source_text, pos - 1)
            source_text = Mid$(source_text, pos + Len(vbCrLf))
        End If

        ' Bold comments.
        next_line = BoldComments(next_line)

        ' Replace special symbols.
        next_line = ReplaceString(next_line, "&", "&amp;")
        next_line = ReplaceString(next_line, "<", "&lt;")
        next_line = ReplaceString(next_line, ">", "&gt;")
        next_line = ReplaceString(next_line, """", "&quot;")

        ' Add this line to the result.
        txt = txt & next_line & vbCrLf
    Loop

    ' Remove the final vbCrLf and end PRE TT.
    txt = Left$(txt, Len(txt) - Len(vbCrLf))
    txt = txt & "</PRE></TT>" & vbCrLf

    ' If the background color is not blank,
    ' finish the table.
    If Len(bg_color) > 0 Then
        txt = txt & "</TD></TR>" & vbCrLf
        txt = txt & "</TABLE>" & vbCrLf
    End If

    SourceToHTML = txt
End Function
Private Sub cmdConvert_Click()
    txtHTML.Text = SourceToHTML(txtSource.Text)
End Sub
' Draw an X on picColor(0) to represent no table.
Private Sub Form_Load()
    picColor(0).AutoRedraw = True
    picColor(0).Line (0, 0)-(picColor(0).ScaleWidth, picColor(0).ScaleHeight)
    picColor(0).Line (picColor(0).ScaleWidth, 0)-(0, picColor(0).ScaleHeight)
End Sub

Private Sub Form_Resize()
Const GAP = 30

Dim hgt As Single
Dim i As Integer

    hgt = (ScaleHeight - cmdConvert.Height - 2 * GAP) / 2
    If hgt < 120 Then hgt = 120
    txtSource.Move 0, 0, ScaleWidth, hgt
    cmdConvert.Move cmdConvert.Left, hgt + GAP
    txtHTML.Move 0, _
        cmdConvert.Top + cmdConvert.Height + GAP, _
        ScaleWidth, hgt

    For i = picColor.LBound To picColor.uBound
        picColor(i).Top = cmdConvert.Top
    Next i
End Sub

Private Sub picColor_Click(Index As Integer)
    picColor(SelectedColor).BorderStyle = vbBSNone
    SelectedColor = Index
    picColor(SelectedColor).BorderStyle = vbFixedSingle
End Sub