HTML Editor Problem

[royjacob]

I've created an HTML Editor which previews and everything. The one hing it still lacks is a feature i've seen in many popular Editors like HotDog Express. i want the color of the text within tags to be different. So, as soon as the user types in "<" the color should change. Is this possible?
By the way the user types all of this in a text box

you would need to use the SelColor property of a RichTextBox..

Here's an example from http://www.planet-source-code.com on how to change the color of certain keywords in a RichTextBox.

[royjacob]

Exactly how do you go about using the SelCor property denniswrenn?

Private Sub Command1_Click()
    RichTextBox1.SelColor = vbRed
End Sub

You select some text in the RTB, then click Command1 and the text turns red.

[royjacob]

I believe the RichTextBox is a different object fom TextBox. How do i get the RTB onto my toolbar?

Right Click on the ToolBar on the left side of the VB IDE, then click on Components when the menu pops up. Then Scroll down to MicroSoft RichText Control. Tick the check box, then click OK, then add it to your form as you would any other control.

I have recently created a color module for visual basic but can easily be modified to work with html..It already colors html a color but not specific strings of html..I was not orginal maker of this code but have recently modified it alot..Uses API and works very quick..Call it int the keypress event..It works if you call it everytime a spacebar is pressed but I would recommend enter becuase thats less overhead..

Option Explicit
'Set the keywords variable to something like this..for html it will be different of course
'   |#Const|#Else|#ElseIf|#End|#If|Alias|Alias|And|As|Base|Binary|Boolean|Byte|ByVal|Call|Case|CBool|CByte|CCur|CDate|CDbl|CDec|CInt|CLng|Close|Compare|Const|CSng|CStr|Currency|CVar|CVErr|Decimal|Declare|DefBool|DefByte|DefCur|DefDate|DefDbl|DefDec|DefInt|DefLng|DefObj|DefSng|DefStr|DefVar|Dim|Do|Double|Each|Else|ElseIf|End|Enum|Eqv|Erase|Error|Exit|Explicit|False|For|Function|Get|Global|GoSub|GoTo|If|Imp|In|Input|Input|Integer|Is|LBound|Let|Lib|Like|Line|Lock|Long|Loop|LSet|Name|New|Next|Not|Object|On|Open|Option|Or|Output|Print|Private|Property|Public|Put|Random|Read|ReDim|Resume|Return|RSet|Seek|Select|Set|Single|Spc|Static|String|Stop|Sub|Tab|Then|Then|True|Type|UBound|Unlock|Variant|Wend|While|With|Xor|Nothing|To|

'// Win API
Public Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function SendMessageByNum Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long


'// Win API Const
Private Const EM_GETFIRSTVISIBLELINE = &HCE
Private Const EM_LINEINDEX = &HBB
Private Const EM_GETRECT = &HB2
Private Const WM_GETFONT = &H31

'// Variables
Public KeyWords As String

'//Variables for FirstVisible/LastVisibles
Dim FirstVisibleLine As Long
Dim LastVisibleLine As Long


Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private Type TEXTMETRIC
  tmHeight As Long
  tmAscent As Long
  tmDescent As Long
  tmInternalLeading As Long
  tmExternalLeading As Long
  tmAveCharWidth As Long
  tmMaxCharWidth As Long
  tmWeight As Long
  tmOverhang As Long
  tmDigitizedAspectX As Long
  tmDigitizedAspectY As Long
  tmFirstChar As Byte
  tmLastChar As Byte
  tmDefaultChar As Byte
  tmBreakChar As Byte
  tmItalic As Byte
  tmUnderlined As Byte
  tmStruckOut As Byte
  tmPitchAndFamily As Byte
  tmCharSet As Byte
End Type
Public Sub Colorize(RTFBox As RichTextBox, CommentColor As Long, StringColor As Long, KeysColor As Long, HTMLColor As Long, Optional All As Boolean = False)

Dim lTextSelPos As Long, lTextSelLen As Long
'// Save the cursor position
lTextSelPos = RTFBox.SelStart
lTextSelLen = RTFBox.SelLength

'// Lock the WindowUpdate of the ReichTextBox
LockWindowUpdate RTFBox.hwnd

'On Error GoTo ErrHandler

Dim i As Long
Dim sBuffer As String, lBufferLen As Long
Dim lSelPos As Long, lSelLen As Long
Dim sTempBuffer As String
Dim sSearchChar As String, lSearchCharLen As Long
Dim SelectColor As Long

With RTFBox
    sBuffer = .Text & " "
    lBufferLen = Len(sBuffer)
    sTempBuffer = ""
If All = True Then
frmMain.StatusBar.Panels(1).Text = "Please Wait... (Scanning For Syntax)"
.SelStart = 0
End If

    For i = FirstVisibleChar(RTFBox, All) To LastVisibleChar(RTFBox, lBufferLen, All)

      Select Case Asc(Mid(sBuffer, i, 1))
      
                    
        Case 47, 38, 39, 60                          'Examples:
          
          If Mid(sBuffer, i, 2) = "//" Then       '// C    Comment
            If Not Mid(sBuffer, i - 1, 3) = "://" Then
            sSearchChar = vbCrLf
            lSearchCharLen = 0
            SelectColor = CommentColor
            End If
          ElseIf Mid(sBuffer, i, 2) = "/*" Then   '// C++  Comment
            sSearchChar = "*/"
            lSearchCharLen = 2
            SelectColor = CommentColor
          ElseIf Mid(sBuffer, i, 4) = "<!--" Then '// HTML Comment
            sSearchChar = "//-->"
            lSearchCharLen = 5
            SelectColor = CommentColor
          ElseIf Mid(sBuffer, i, 1) = "'" Then    '// VB   Comment
                sSearchChar = vbCrLf
                lSearchCharLen = 0
                SelectColor = CommentColor
          ElseIf Mid(sBuffer, i, 1) = "<" Then    '//HTML
            sSearchChar = ">"
            lSearchCharLen = 1
            SelectColor = HTMLColor
                   
          Else                                    '// None
            GoTo ExitComment
          End If
          
          '// Kill TempBuffer
          sTempBuffer = ""
          
          '// Colorize the comment string
          .SelStart = i - 1
          lSelLen = InStr(i, sBuffer, sSearchChar) + lSearchCharLen
          If lSelLen <> lSearchCharLen Then '// FileEnd ?
            lSelLen = lSelLen - i
          Else
            lSelLen = lBufferLen - i
          End If
          .SelLength = lSelLen
          If Not .SelColor = vbBlack Then GoTo ExitComment:
          .SelColor = SelectColor
          i = .SelStart + .SelLength
          
ExitComment:

        Case 97 To 122, 65 To 90, 48 To 57, 34, 35
          '// a to  z ,  A to Z , #
          '// Only this char can be colorize
          If sTempBuffer = "" Then lSelPos = i
          sTempBuffer = UCase(sTempBuffer & Mid(sBuffer, i, 1))
          
          
          
          
        Case Else
          
          If Trim(sTempBuffer) <> "" Then
            If InStr(sTempBuffer, """") Then GoTo skip

            If InStr(1, KeyWords, "|" & sTempBuffer & "|", 1) <> 0 Then
            .SelStart = lSelPos - 1
            .SelLength = 1
            If Not .SelColor = vbBlack Then GoTo skip
            .SelText = UCase(.SelText)
            .SelStart = lSelPos - 1
            .SelLength = Len(sTempBuffer)
            .SelColor = KeysColor
skip:
            End If
          End If
        
          sTempBuffer = ""
        End Select
      Next

End With

ErrHandler:

'// Set the Cursor to the old position
RTFBox.SelStart = lTextSelPos
RTFBox.SelLength = lTextSelLen
If All = True Then
frmMain.StatusBar.Panels(1).Text = "Scanning Complete!"
End If

'// Unlock the WindoUpdate-Lock
LockWindowUpdate 0

End Sub

Private Function FirstVisibleChar(RTFBox As RichTextBox, Optional All As Boolean = False) As Long

  FirstVisibleLine = SendMessage(RTFBox.hwnd, EM_GETFIRSTVISIBLELINE, 0, 0&)
  FirstVisibleChar = SendMessageByNum(RTFBox.hwnd, EM_LINEINDEX, FirstVisibleLine, 0&)
  If FirstVisibleChar = 0 Then FirstVisibleChar = 1
End Function


Private Function LastVisibleChar(RTFBox As RichTextBox, LenFile As Long, All As Boolean) As Long
Dim rc As RECT
Dim tm As TEXTMETRIC
Dim hdc As Long
Dim lFont As Long
Dim OldFont As Long
Dim di As Long
Dim lc As Long
Dim VisibleLines As Long

  lc = SendMessage(RTFBox.hwnd, EM_GETRECT, 0, rc)
  lFont = SendMessage(RTFBox.hwnd, WM_GETFONT, 0, 0)
  hdc = GetDC(RTFBox.hwnd)
  If lFont <> 0 Then OldFont = SelectObject(hdc, lFont)
  di = GetTextMetrics(hdc, tm)
  If lFont <> 0 Then lFont = SelectObject(hdc, OldFont)
  
  If All = True Then
  VisibleLines = Len(frmMain.RichTxtBox(CurIndex).Text)
  Else
  VisibleLines = (rc.Bottom - rc.Top) / tm.tmHeight + 20 'the + 20 means 20 lines not visible are colored
  End If
  
  di = ReleaseDC(RTFBox.hwnd, hdc)
  
  LastVisibleLine = SendMessage(RTFBox.hwnd, EM_GETFIRSTVISIBLELINE, 0, 0&)
  LastVisibleLine = LastVisibleLine + VisibleLines
  
  LastVisibleChar = SendMessageByNum(RTFBox.hwnd, EM_LINEINDEX, LastVisibleLine, 0&)
  If LastVisibleChar = -1 Or LastVisibleChar = 0 Then LastVisibleChar = LenFile
End Function