Printable View
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.
Exactly how do you go about using the SelCor property denniswrenn?
You select some text in the RTB, then click Command1 and the text turns red.Code:Private Sub Command1_Click()
RichTextBox1.SelColor = vbRed
End Sub
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..
Code:
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