colorcode.bas

一个完整的HTML编辑器

            bef = Mid$(frmDocument.rtfText.Text, 1, tag_open - 1)
            
            'Find the end of the next tag...
            tag_close = InStr(tag_open, frmDocument.rtfText.Text, ">")

            'Get the current HTML tag...
            Curr = Mid$(frmDocument.rtfText.Text, tag_open, tag_close - tag_open + 1)
            
            If tag_close <> 0 Then
                Select Case Left$(Curr, 3)
                    Case "<!-"
                        ' It's a comment...
                        tag_close = InStr(tag_open, frmDocument.rtfText.Text, "->") + 1
                            frmDocument.rtfText.SelStart = tag_open - 1
                            frmDocument.rtfText.SelLength = tag_close - tag_open + 1
                            frmDocument.rtfText.SelColor = m_CommentCol
                    Case Else
                        ' This colors basic Html tags and then colors the attributes
                        cycleAttrib Curr, tag_open, tag_close
                End Select
            End If
            
            If tag_close = 0 Or tag_close >= endchar Then
                ' If we are coloring tags and it's over the end tag then
                ' get me out of this loop and don't color anymore
                Exit Do
            End If
        Else
            Exit Do
        End If
    Loop
    frmDocument.PrgBar.Visible = False
    frmDocument.rtfText.Visible = True
    ' Color ASP Stuff only if we need to. We have a special function for coloring ASP tags so we won't
    ' worry if this deals with it or not.
    If StopAsp = False Then
        ASPColorCode startchar, endchar
    End If
    
    frmDocument.rtfText.SelStart = oldselstart
    frmDocument.rtfText.SelLength = oldsellen
    frmDocument.rtfText.HideSelection = False
    frmDocument.rtfText.SetFocus
    
    'frmMain.trapUndo = True
    Exit Function
    
ErrHandler:
    Exit Function
End Function

' This function colorizes ASP code

Private Function ASPColorCode(Optional startchar As Long = 1, Optional endchar As Long = -1)
On Error GoTo ErrHandler
    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
    
    '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
    
    ' Now lets loop through the tags and color code it
    Do
        ' 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...
            bef = Mid$(frmDocument.rtfText.Text, 1, tag_open - 1)
            
            'Find the end of the next tag...
            tag_close = InStr(tag_open, frmDocument.rtfText.Text, "%>")

            'Get the current HTML tag...
            Curr = Mid$(frmDocument.rtfText.Text, tag_open, tag_close - tag_open + 1)
            
            If tag_close <> 0 Then
                Select Case Left$(Curr, 2)
                    Case "<%"
                        ' It's asp
                        tag_close = InStr(tag_open, frmDocument.rtfText.Text, "%>") + 1
                            frmDocument.rtfText.SelStart = tag_open - 1
                            frmDocument.rtfText.SelLength = tag_close - tag_open + 1
                            frmDocument.rtfText.SelColor = m_AspCol
                    Case Else
                        ' it's not an asp tag so do nothing
                End Select
            End If
            
            If tag_close = 0 Or tag_close >= endchar Then
                ' If we are coloring tags and it's over the end tag then
                ' get me out of this loop and don't color anymore
                Exit Do
            End If
        Else
            Exit Do
        End If
    Loop
    
    frmDocument.rtfText.SelStart = oldselstart
    frmDocument.rtfText.SelLength = oldsellen
    frmDocument.rtfText.HideSelection = False
    frmDocument.rtfText.SetFocus
    
    'frmMain.trapUndo = True
    
    Exit Function
    
ErrHandler:
    Exit Function
End Function

' This cycles through the html and comes back with the right tag colors for the tag and all of it's
' attributes

Private Function cycleAttrib(CurrTag As String, opentag As Long, closetag As Long)
    
    Dim fPos As Long, sPos As Long, qPos As Long, qnPos As Long, aPos As Long, tBeg As Long, tEnd As Long
    Dim isFirstCycle As Boolean
    Dim eTag As String
    Dim sPosTxt As String
    Dim LeftOver As Long
    Dim EndTag As Long, QuotePos As Long, QuoteEndPos As Long
    
    'frmDocument.trapUndo = False
    
    eTag = CurrTag
    isFirstCycle = True

    Do While Len(eTag) > 0
        fPos = InStr(1, eTag, "=")

        If (fPos = 0 And isFirstCycle = True) Then
            ' This just checks to see if it's a basic html tag w/ no attributes and if so colors that
            ' without going through the rest of the junk.
            frmDocument.rtfText.SelStart = opentag - 1
            frmDocument.rtfText.SelLength = closetag - opentag + 1
            frmDocument.rtfText.SelColor = m_TagCol
            Exit Function
        ' It looks like we have an attribute. Here comes the hard part...
        ElseIf fPos <> 0 Then 'Put in the color info...
            If Left$(eTag, 1) = "<" Then
                ' This brings back the entire tag. something like:
                ' <img src="blah.jpg" onclick="blah">
                ' and then color codes the entire thing
                tBeg = opentag
                tEnd = opentag + fPos

                ' Color Code the entire tag first
                frmDocument.rtfText.SelStart = tBeg - 1
                frmDocument.rtfText.SelLength = closetag - tBeg + 1
                frmDocument.rtfText.SelColor = m_TagCol

                ' This brings back the text that is past the attribute. in the previous example:
                ' "blah.jpg" onclick="blah">
                eTag = Mid$(eTag, fPos + 1)
                LeftOver = closetag - Len(eTag)
            End If
        End If
        
        'Find the first instance of a space in the
        'part of the tag that we have left...
        sPos = InStr(1, eTag, Chr$(32))

        'Gets the text up to the next space...
        sPosTxt = Mid$(eTag, 1, sPos)
        
        'Checks to see if there's a quote in the text...
        qPos = InStr(1, sPosTxt, Chr$(34))

        'If there's a quote found, then we need to find
        'its end...
        If qPos <> 0 Then
            'Look for the next quote...
            qnPos = InStr(2, eTag, Chr$(34))

            If qnPos <> 0 Then
                sPosTxt = Mid$(eTag, 1, qnPos)
            End If
        End If

        LeftOver = closetag - Len(eTag)
        frmDocument.rtfText.SelStart = LeftOver
        frmDocument.rtfText.SelLength = Len(sPosTxt)
        frmDocument.rtfText.SelColor = m_AttribCol
        
        'Truncates the tag so there's no attrib value left...
        eTag = Mid$(eTag, Len(sPosTxt) + 1)

        'Find the next position of an equal sign...
        sPos = InStr(1, eTag, "=")

        'If there's no =, then we know we're on the last
        'attrib value, so we need to put in some final
        'info...all that's left is something like:
        '"#ffffff">
        If sPos = 0 Then
            'Put in the attrib color before the ">"
            'if it's the last attribute...
            eTag = Mid$(eTag, 1, Len(eTag) - 1)

            'Insert the RTF info...
            'bef = bef & infoRTF & AttribInfo & eTag
            frmDocument.rtfText.SelStart = LeftOver
            frmDocument.rtfText.SelLength = Len(eTag)
            frmDocument.rtfText.SelColor = m_AttribCol

            'Truncate the end...
            sPos = Len(eTag)
            Exit Do
        End If

        'Truncates the tag appropriately...
        eTag = Mid$(eTag, sPos + 1)
        isFirstCycle = False

        'If there's nothing left, then we need to exit
        'the loop so it doesn't loop infinitely...
        If sPos = 0 And qPos = 0 Then Exit Do
    Loop
    
    'frmMain.trapUndo = True
    Exit Function
End Function