colorcode.bas

一个完整的HTML编辑器

Attribute VB_Name = "ColorCode"
Option Explicit
Public m_TextCol As String
Public m_AttribCol As String
Public m_TagCol As String
Public m_CommentCol As String
Public m_AspCol As String

Public Sub HtmlHighlight()
On Error Resume Next
    'frmMain.trapUndo = False
    ' Color Html and asp
    HtmlColorCode
    
    ' Move back to the start of the thing
    frmDocument.rtfText.SelStart = 0
    'frmMain.trapUndo = True
End Sub

Public Function KeyPressEvent(KeyAscii As Integer) As Integer
    Static cInAttrib As Boolean, cInTag As Boolean
    Static cInAttribQuote As Boolean, cTypedIn As Boolean
    Static cInComment As Boolean
    Static cInASP As Boolean
    Static cInFunction As Boolean
    
    'frmMain.trapUndo = False
    
    Dim cChar As String
'frmDocument.rtfText
    With frmDocument.rtfText
        cChar = Chr$(KeyAscii)
        
        If cInTag = False And cInAttrib = False And cInComment = False And cInASP = False Then
            .SelColor = m_TextCol
        End If

        If cInTag = True And (cInAttrib = True Or cInAttribQuote = True) Then
            .SelColor = m_AttribCol
        End If

        If cChar = "<" Then
            .SelColor = m_TagCol
            cInTag = True
            cTypedIn = True
        End If

        If cChar = "=" And cInTag = True Then
            cInAttrib = True
        End If

        If cChar = Chr$(34) And cInAttrib = True And cInAttribQuote = True Then
            cInAttrib = False
            cInAttribQuote = False
        ElseIf cChar = Chr$(34) And cInAttrib = True And cInAttribQuote = False Then
            cInAttribQuote = True
        End If

        If cChar = " " And (cInAttribQuote = False And cInTag = True) Then
            .SelColor = m_TagCol
            cInAttrib = False
        End If

        If cChar = "!" And Mid$(.Text, .SelStart, 1) = "<" Then

            .SelStart = .SelStart - 1
            .SelLength = 1
            .SelColor = m_CommentCol
            .SelText = "<!--"

            cInTag = False
            cInAttrib = False
            cInASP = False
            cInComment = True

            KeyAscii = 0
        End If
        
        If cChar = "%" And Mid$(.Text, .SelStart, 1) = "<" Then

            .SelStart = .SelStart - 1
            .SelLength = 1
            .SelColor = m_AspCol
            .SelText = "<%"

            cInTag = False
            cInAttrib = False
            cInASP = True
            cInComment = False

            KeyAscii = 0
        End If

        If cChar = ">" Then
            If cInComment = False And cInASP = True Then
                .SelColor = m_AspCol
            ElseIf cInComment = True And cInASP = False Then
                .SelColor = m_CommentCol
            ElseIf cInComment = False And cInASP = False Then
                .SelColor = m_TagCol
            End If
            
            cInTag = False
            cInASP = False
            cInComment = False
            cTypedIn = False
        End If

    End With

    KeyPressEvent = KeyAscii
    
    'frmMain.trapUndo = True
ErrExit:
    Exit Function
End Function

' Insert text w/tag coloring if necessary

Public Sub InsertTag(Tag$, StopAsp As Boolean)
Dim S As Long
    'frmMain.trapUndo = False
    S = frmDocument.rtfText.SelStart
    If Len(frmDocument.rtfText.SelText) > 0 Then frmDocument.rtfText.SelText = ""
    frmDocument.rtfText.SelText = Tag$
    
    If StopAsp = True Then
        HtmlColorCode S, S + Len(Tag), True
Else

        HtmlColorCode S, S + Len(Tag), False

    End If
    
    'frmMain.trapUndo = True
End Sub

' Insert Asp code with asp coloring

Public Sub InsertAspTag(Tag$)
Dim U As Long
    U = frmMain.rtfText.SelStart
    If Len(frmMain.rtfText.SelText) > 0 Then frmMain.rtfText.SelText = ""
    frmMain.rtfText.SelText = Tag$
    
    frmMain.trapUndo = False
    ASPColorCode U, U + Len(Tag)
    frmMain.trapUndo = True
End Sub

' This function determines whether the caret is currently outside a tag. This was a royal pain in the ass.

Public Function IsOutsideTag()
On Error Resume Next
Dim LastGT As Long, LastLT As Long, NextGT As Long, NextLT As Long
Dim EndTag As Long, StartTag As Long
Dim txt$, Start As Long, Start2 As Long
Dim InMainTag As Boolean, InEndTag As Boolean
    
    txt = frmDocument.rtfText.Text
    Start = frmDocument.rtfText.SelStart
    
    If Start = 0 Then
        m_TextCol = vbBlack
        Exit Function
    Else
        EndTag = InStr(Start + 1, txt, ">")
        StartTag = InStr(Start + 1, txt, "<")

        If StartTag > EndTag Then
            InMainTag = True
        Else
            InMainTag = False
        End If
        
        LastLT = RevInStr(txt, "<", Start + 1)
        LastGT = RevInStr(txt, ">", Start + 1)

        If LastLT < LastGT Then
            InEndTag = True
        Else
            InEndTag = False
        End If

        If InMainTag = True Or InEndTag = True Then
            m_TextCol = frmDocument.rtfText.SelColor
        Else
            m_TextCol = vbBlack
        End If
    End If
End Function

' ##########################################################################################
' These are the main color coding functions. These are not called ever by the user.
' ##########################################################################################

' This is the main color coding function. This does everything html, comments, and attributes. It also calls
' the ASP color coding function if nessasary

Public Function HtmlColorCode(Optional startchar As Long = 1, Optional endchar As Long = -1, Optional StopAsp As Boolean = False)
On Error GoTo ErrHandler
    ' These are the variables for the tags for ColorCoding
    Dim CommentOpenTag As String
    Dim CommentCloseTag As String

    Dim oldselstart As Long, oldsellen As Long
    
    ' These are place holders for the color coding
    Dim tag_open As Long
    Dim tag_close As Long
    Dim bef As String
    Dim Curr As String
    Dim CI As Integer
    'frmMain.trapUndo = False
    
    ' Find out where the cursor is
    oldselstart = frmDocument.rtfText.SelStart
    oldsellen = frmDocument.rtfText.SelLength
    
    If endchar = -1 Then endchar = Len(frmDocument.rtfText.Text)
    If startchar = 0 Then startchar = 1

    ' These are the close tags for colorcoding
    
    tag_close = startchar
    
    ' Lets try to hide the color coding from the user:
    frmDocument.rtfText.HideSelection = True
    CI = 0
    frmDocument.rtfText.Visible = False
    frmDocument.PrgBar.Visible = True
    ' Now lets loop through the tags and color code it
    Do
    CI = CI + 1
    If CI = 100 Then
    CI = 0
    End If
    
    frmDocument.PrgBar.Value = CI
        ' See where the next tag starts. if any
        tag_open = InStr(tag_close, frmDocument.rtfText.Text, "<")
        
        'If so, then color it...
        If tag_open <> 0 Then  'Found a tag
            
            'Get everything before the tag we're on...