if you dont want to copy all the code... download the project here

http://denniswrenn.virtualave.net/HTMLColorChanger.zip


paste this into the form code module
Code:
Private Sub Form_Load()
m_TagCol = vbBlue
End Sub

Private Sub rtfText_Change()
    If Not trapUndo Then Exit Sub 'because trapping is disabled

    Dim newElement As New UndoElement   'create new undo element
    Dim c%, l&

    'remove all redo items because of the change
    For c% = 1 To RedoStack.Count
        RedoStack.Remove 1
    Next c%

    'set the values of the new element
    newElement.SelStart = rtfText.SelStart
    newElement.TextLen = Len(rtfText.Text)
    newElement.Text = rtfText.Text

    'add it to the undo stack
    UndoStack.Add Item:=newElement
    
'    EnableControls
End Sub



Private Sub rtfText_KeyDown(KeyCode As Integer, Shift As Integer)
'GetEditStatus
Dim TypedIn As String
    If Shift And vbCtrlMask Then
        If KeyCode > vbKey0 And KeyCode < vbKey7 Then
            Dim HeadingTag As String
            HeadingTag = "<H" & CStr(KeyCode - vbKey0) & "></H" & CStr(KeyCode - vbKey0) & ">"
            InsertTag HeadingTag, True
            PlaceCursor HeadingTag, 5
            rtfText.SelColor = vbBlack
        Else
            Select Case KeyCode
            Case vbKeyV
                ' User pressed Ctrl+V  - Paste
                Dim a$, S As Long
                S = rtfText.SelStart ' save this since selstart moves up after the paste
                a = Clipboard.GetText(vbCFText)
                rtfText.SelText = ""
                rtfText.SelText = a    ' This removes any unwanted formatting (font, &c)
                HtmlColorCode S, rtfText.SelStart
                
                KeyCode = 0
            Case vbKeyReturn
                InsertTag "<P>", True
                rtfText.SelColor = vbBlack
                KeyCode = 0
            Case vbKeySpace
                rtfText.SelColor = vbBlack
                rtfText.SelText = "&nbsp;"
                KeyCode = 0
            End Select
        End If
    ElseIf Shift And vbShiftMask Then
        If KeyCode = vbKeyReturn Then
            InsertTag "<BR>", True
            rtfText.SelColor = vbBlack
            KeyCode = 0
        End If
    End If
    IsOutsideTag
    
    
    
    End Sub


Private Sub rtfText_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyControl Then
        CtlKey = False
    End If
    IsOutsideTag
    rtfText.SetFocus
End Sub



Public Sub GetEditStatus()
   Dim lLine As Long, lCol As Long
   Dim cCol As Long, lChar As Long, i As Long

   lChar = rtfText.SelStart + 1

   ' Get the line number
   lLine = 1 + SendMessageLong(rtfText.hwnd, EM_LINEFROMCHAR, _
           rtfText.SelStart, 0&)

   ' Get the Character Position
   cCol = SendMessageLong(rtfText.hwnd, EM_LINELENGTH, lChar - 1, 0&)

   i = SendMessageLong(rtfText.hwnd, EM_LINEINDEX, lLine - 1, 0&)
   lCol = lChar - i

    lbl_Lines.Caption = lbl_Lines.Caption & lLine & vbCrLf
   'sbStatusBar.Panels(1).Text = "Line: " & lLine & ", Col: " & lCol

End Sub


Public Sub PlaceCursor(Text$, Cursor As Long)
Dim T As Long
    T = rtfText.SelStart
    rtfText.SelStart = (T + Len(Tag)) - Cursor
End Sub

Private Sub rtfText_KeyPress(KeyAscii As Integer)
'pOKUS
Dim Button As Integer
Dim Shift As Integer
Dim x As Single
Dim y As Single
'Pokus
Dim Key As String
Key = Chr(KeyAscii)
If Key = "<" Then

'################################
' Gives the Combo to select from
'################################
'MsgBox "Syntax AutoCoplete will be included in next version."


'If lblAutoSyntax.Caption = "1" Then
'PopupMenu fMainForm.syntax
'End If



End If
On Error Resume Next
    KeyAscii = KeyPressEvent(KeyAscii)
End Sub
paste this into and class module called "UndoElement"

Code:
Public SelStart As Long  'start position in text box
Public TextLen As Long
Public Text As String
paste this into a regular module called "ColorCode"

Code:
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...
            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
paste this into a module called "Declares"

Code:
Public Declare Function SendMessage Lib "user32" Alias _
    "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
        ByVal wParam As Long, lParam As Long) As Long


Public Const WM_USER = &H400
Public Const EM_HIDESELECTION = WM_USER + 63
paste this into a module called "VB6Function"

Code:
Option Explicit
' These are vb6 functions not in vb5. If using vb 6 comment out these functions or
' remove this module from the project... note that i have edited some of these functions
' for my use and the vb 6 functions may not work the same. You could always change the
' name of these functions and replace the call in the code. These functions were taken from
' support.microsoft.com

Public Function RevInStr(ByVal sIn As String, sFind As String, Optional nStart As Long = 1, Optional bCompare As VbCompareMethod = vbBinaryCompare) As Long
Dim nPos As Long
    nPos = InStr(nStart, sIn, sFind, bCompare)
    If nPos = 0 Then
        RevInStr = 0
    Else
        RevInStr = Len(sIn) - nPos - Len(sFind) + 2
    End If
End Function
 
' End VB6 functions
[Edited by denniswrenn on 05-22-2000 at 03:24 PM]