The following posts contain a few things that you can do with RichTextBoxes that you might not have known that you could do. If any of you know of other non-standard things that can be done with RichTextBoxes, feel free to add to this list.
Since there is no .SelHighlight property of the RichTextBox control, I created one.
Code:
Public Sub HighLight(RTB As RichTextBox, lColor As Long)
'add new color to color table
'add tags \highlight# and \highlight0
'where # is new color number
Dim iPos As Long
Dim strRTF As String
Dim bkColor As Integer
With RTB
iPos = .SelStart
'bracket selection
.SelText = Chr(&H9D) & .SelText & Chr(&H81)
strRTF = RTB.TextRTF
'add new color
bkColor = AddColorToTable(strRTF, lColor)
'add highlighting
strRTF = Replace(strRTF, "\'9d", "\up1\highlight" & CStr(bkColor) & "")
strRTF = Replace(strRTF, "\'81", "\highlight0\up0 ")
.TextRTF = strRTF
.SelStart = iPos
End With
End Sub
Notice that in addition to inserting the \highlight tags I also insert \up# tags.
This is so that I can check to see if a selection is highlighted by querying the
.SelCharOffset function. This routine relies on the following function that adds
a new color to the RTF color table
Code:
Function AddColorToTable(strRTF As String, lColor As Long) As Integer
Dim iPos As Long, jpos As Long
Dim ctbl As String
Dim tagColors
Dim nColors As Integer
Dim tagNew As String
Dim i As Integer
Dim iLen As Integer
Dim split1 As String
Dim split2 As String
'make new color into tag
tagNew = "\red" & CStr(lColor And &HFF) & _
"\green" & CStr(Int(lColor / &H100) And &HFF) & _
"\blue" & CStr(Int(lColor / &H10000))
'find colortable
iPos = InStr(strRTF, "{\colortbl")
If iPos > 0 Then 'if table already exists
jpos = InStr(iPos, strRTF, ";}")
'color table
ctbl = Mid(strRTF, iPos + 12, jpos - iPos - 12)
'array of color tags
tagColors = Split(ctbl, ";")
nColors = UBound(tagColors) + 2
'see if our color already exists in table
For i = 0 To UBound(tagColors)
If tagColors(i) = tagNew Then
AddColorToTable = i + 1
Exit Function
End If
Next i
'{\fonttbl{\f0\fnil\fcharset0 Verdana;}}
'{\colortbl ;\red0\green0\blue0;\red128\green0\blue255;}
split1 = Left(strRTF, jpos)
split2 = Mid(strRTF, jpos + 1)
strRTF = split1 & tagNew & ";" & split2
AddColorToTable = nColors
Else
'color table doesn't exists, let's make one
iPos = InStr(strRTF, "{\fonttbl") 'beginning of font table
jpos = InStr(iPos, strRTF, ";}}") + 2 'end of font table
split1 = Left(strRTF, jpos)
split2 = Mid(strRTF, jpos + 1)
strRTF = split1 & "{\colortbl ;" & tagNew & ";}" & split2
AddColorToTable = 1
End If
End Function
Two other functions that the RichTextBox control does not gives us are super and subscripting.
As before we can accomplish this by inserting RTF code. Notice again that I also add \up0
and \dn0 tags so that I can determine if text has been subscripted by querying the
.SelCharOffset property.
Code:
Public Sub SetSubScript(RTB As RichTextBox)
Dim iPos As Long
Dim strRTF As String
With RTB
If .SelCharOffset >= 0 Then
'subscript the current selection
iPos = .SelStart
.SelText = Chr(&H9D) & .SelText & Chr(&H81)
strRTF = Replace(.TextRTF, "\'9d", "\sub\dn2 ")
.TextRTF = Replace(strRTF, "\'81", "\nosupersub\up0 ")
.SelStart = iPos
Else 'turn off subscripting
.SelText = Chr(&H9D) & .SelText
strRTF = .TextRTF
.TextRTF = Replace(strRTF, "\'9d", "\nosupersub\up0 ", , 1)
End If
End With
End Sub
Public Sub SetSuperScript(RTB As RichTextBox)
'add tags \super\up1 and \nosupersub\up0
Dim iPos As Long
Dim strRTF As String
With RTB
iPos = .SelStart
If RTB.SelCharOffset <= 0 Then
'superscript the current selection
.SelText = Chr(&H9D) & .SelText & Chr(&H80)
strRTF = Replace(.TextRTF, "\'9d", "\super\up2 ")
.TextRTF = Replace(strRTF, "\'81", "\nosupersub\up0 ")
Else 'turn off
.SelText = Chr(&H9D) & .SelText
strRTF = .TextRTF
.TextRTF = Replace(strRTF, "\'9d", "\nosupersub\up0 ", , 1)
End If
.SelStart = iPos
End With
End Sub
Another useful functionality that can be added to the RichTextBox controls is the ability to insert tables.
The RichTextBox controls support a limited subset of the table related Rich Text Format tags, but none
of that is made accessible to users of the control. I've attached a class that you can use to insert tables
into your RichTextBox controls.
Properties - all sizes are in twips
xLeft - Position of the left edge of the table
isCentered - Set to True to center the table
Rows - Sets or returns the number of rows in the table
Columns - Sets or returns the number of columns in the table
Row - An Array of Rows (1 to Rows)
Column - An Array of columns (1 to Columns)
Column(i).xWidth - Width of the ith column
Cell - A 2-d Array of Cells (1 to Rows, 1 to Columns)
Cell(r, c).Contents - Sets or returns the contents of the cell
Methods
InsertTable(RTB As RichTextBox) - Inserts the table into the RichTextBox at the currrent cursor position.
An example of use is
Code:
Option Explicit
Dim RTFtable As clsRTFtable
Private Declare Function LockWindowUpdate Lib "user32" ( _
ByVal hwndLock As Long _
) As Long
Private Sub Command1_Click()
Dim i As Integer
Set RTFtable = New clsRTFtable
'stop flicker
Call LockWindowUpdate(RichTextBox1.hWnd)
For i = 1 To 5
With RTFtable
'set the size of the table
.Columns = 3
.Rows = 2
'fill the cells
'Row 1
.Cell(1, 1).Contents = "Row 1"
.Cell(1, 2).Contents = "Column2"
.Cell(1, 3).Contents = "Column3"
'Row 2
.Cell(2, 1).Contents = "Row2"
.Cell(2, 2).Contents = "R2C2"
.Cell(2, 3).Contents = "R2C3"
'do we want to center it on the page?
.isCentered = True
'insert the table at the current cursor postion
.InsertTable RichTextBox1
End With
Next i
Call LockWindowUpdate(0)
End Sub
There are several ways to insert pictures into a RichTextBox control.
This is one method that does not rely on the clipboard, but does use some
metafile stuff. Here is the routine to insert the picture
Code:
'Inserts the picture at the current insertion point
Public Function InsertPicture(RTB As RichTextBox, pic As StdPicture)
Dim strRTFall As String
Dim lStart As Long
With RTB
.SelText = Chr(&H9D) & .SelText & Chr(&H81)
strRTFall = .TextRTF
strRTFall = Replace(strRTFall, "\'9d", PictureToRTF(pic))
.TextRTF = strRTFall
'position cursor past new insertion
lStart = .Find(Chr(&H81))
strRTFall = Replace(strRTFall, "\'81", "")
.TextRTF = strRTFall
.SelStart = lStart
End With
End Function
Here is the routine that converts the picture into an RTF string
Code:
'returns the RTF string representation of our picture
Public Function PictureToRTF(pic As StdPicture) As String
Dim hMetaDC As Long, hMeta As Long, hPicDC As Long, hOldBmp As Long
Dim Bmp As BITMAP, Sz As Size, Pt As POINTAPI
Dim sTempFile As String, screenDC As Long
Dim headerStr As String, retStr As String, byteStr As String
Dim ByteArr() As Byte, nBytes As Long
Dim fn As Long, i As Long, j As Long
sTempFile = App.Path & "\~pic" & ((Rnd * 1000000) + 1000000) \ 1 & ".tmp" 'some temprory file
If Dir(sTempFile) <> "" Then Kill sTempFile
'Create a metafile which is a collection of structures that store a
'picture in a device-independent format.
hMetaDC = CreateMetaFile(sTempFile)
'set size of Metafile window
SetMapMode hMetaDC, MM_ANISOTROPIC
SetWindowOrgEx hMetaDC, 0, 0, Pt
GetObject pic.Handle, Len(Bmp), Bmp
SetWindowExtEx hMetaDC, Bmp.Width, Bmp.Height, Sz
'save sate for later retrieval
SaveDC hMetaDC
'get DC compatible to screen
screenDC = GetDC(0)
hPicDC = CreateCompatibleDC(screenDC)
ReleaseDC 0, screenDC
'set out picture as new DC picture
hOldBmp = SelectObject(hPicDC, pic.Handle)
'copy our picture to metafile
BitBlt hMetaDC, 0, 0, Bmp.Width, Bmp.Height, hPicDC, 0, 0, vbSrcCopy
'cleanup - close metafile
SelectObject hPicDC, hOldBmp
DeleteDC hPicDC
DeleteObject hOldBmp
'retrieve saved state
RestoreDC hMetaDC, True
hMeta = CloseMetaFile(hMetaDC)
DeleteMetaFile hMeta
'header to string we want to insert
headerStr = "{\pict\wmetafile8" & _
"\picw" & pic.Width & "\pich" & pic.Height & _
"\picwgoal" & Bmp.Width * Screen.TwipsPerPixelX & _
"\pichgoal" & Bmp.Height * Screen.TwipsPerPixelY & _
""
'read metafile from disk into byte array
nBytes = FileLen(sTempFile)
ReDim ByteArr(1 To nBytes)
fn = FreeFile()
Open sTempFile For Binary Access Read As #fn
Get #fn, , ByteArr
Close #fn
Dim nlines As Long
'turn each byte into two char hex value
i = 0
byteStr = ""
Do
byteStr = byteStr & vbCrLf
For j = 1 To 39
i = i + 1
If i > nBytes Then Exit For
byteStr = byteStr & Hex00(ByteArr(i))
Next j
Loop While i < nBytes
'string we will be inserting
retStr = headerStr & LCase(byteStr) & vbCrLf & "}"
PictureToRTF = retStr
'remove temp metafile
Kill sTempFile
End Function
'adds leading zero to hex value if needed.
Public Function Hex00(icolor As Byte) As String
Hex00 = Right("0" & Hex(icolor), 2)
End Function
Until recently I didn't know that you could access the "Find-And-Replace" Common Dialog.
Here is a class that makes it easy to access. The class will work with either a standard TextBox or a RichTextBox.
Here is an example of how you might use the class.
Code:
Option Explicit
'declare with events so that we can override the default
'behavior of the class and/or handle ShowHelp
Dim WithEvents FindDialog As clsFindandReplace
Private Sub Form_Load()
Set FindDialog = New clsFindandReplace
End Sub
Private Sub Command2_Click()
'show the Find and Replace dialog box
'pass the handle of our RichTextBox to
'the class
FindDialog.ShowReplace RTB.hwnd
End Sub
Here is a class that provides full spell checking functionality for the RichTextBox. This class has only two methods:
GetSpellingErrors checks the spelling in all the text of a RTB and returns the number of spelling errors found and marks then all. A right-click on any error brings up a popup menu with suggested changes. If the user selects a change from the menu, then the replacement is made.
ClearSpelling clears all the marked errors.
Here is an example of use:
Code:
Option Explicit
Private SpellCheck As clsSpellCheck
Private Sub cmdSpellCheck_Click()
SpellCheck.GetSpellingErrors RTB
End Sub
Private Sub cmdStopSpell_Click()
SpellCheck.ClearSpelling
End Sub
Private Sub Form_Load()
Set SpellCheck = New clsSpellCheck
RTB.LoadFile App.Path & "\recipe.rtf"
End Sub
This code also provides an example of several other things.
How to implement the EN_LINK notification function of the RichTextBox. This notification is usually used to mark hyperlinks and respond to mouse events over them. I use it to mark spelling errors and to bring up a popup menu of spelling suggestions for the user to select from.
I have included a class that is used to create and respond to popup menus. I put this functionality into a class because I wanted all the spell checking functionality contained within a class with none of the code in the form.
Also included is my "Cute Little Subclasser" class. I use this class whenever I want subclassing capabilities. When this class is declared WithEvents, the user can write code to respond to Windows messages within the form or class's own module. It also is a little more stable than doing your own subclassing since it always remembers to turn itself off.
Attached is the source code for all the above mentioned items PLUS a free mispelled recipe!
Here is some simple code that will give you the cursor position in a RichTextBox, It gives you the line number and the column number of the cursor. Attached is a project that demonstrates use of the routine.
Code:
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any _
) As Long
Private Const EM_GETLINECOUNT = &HBA
Private Const EM_LINEINDEX = &HBB
Private Sub GetCursorPos(RTB As RichTextBox, iLine As Integer, iPos As Integer)
Dim lCount As Long
Dim i As Long
Dim LN As Long
lCount = SendMessage(RTB.hwnd, EM_GETLINECOUNT, 0&, 0&)
LN = SendMessage(RTB.hwnd, EM_LINEINDEX, -1&, 0&)
For i = 1 To lCount
If LN = SendMessage(RTB.hwnd, EM_LINEINDEX, i - 1, 0) Then Exit For
Next i
iLine = i
iPos = RTB.SelStart - LN + 1
End Sub
The RichTextBox control has the ability to detect URLs as they are typed. It can convert this text into a hyperlink which can launch a browser when clicked.
To turn on Auto URL detection simply send the RTB an EM_AUTOURLDETECT message.
When the control detects that a URL is being entered, it reformats the text being entered so that it looks like a hyperlink and marks that text with a CFE_LINK effect.
When the mouse pointer is over text with a CFE_LINK effect, the RTB can be configured to send a message to its parent. In order to respond to mouse events over the hyperlink text, the parent has to be subclassed or hooked.
The following code shows how to setup Auto URL detection
Code:
Public Sub EnableAutoURLDetection(RTB As RichTextBox)
'enable auto URL detection
SendMessage RTB.hwnd, EM_AUTOURLDETECT, 1&, ByVal 0&
'subclass the parent of the RTB to receive EN_LINK notifications
Set FormSubClass = New clsSubClass
FormSubClass.Enable RTB.Parent.hwnd
'set RTB to notify parent when user has clicked hyperlink
SendMessage RTB.hwnd, EM_SETEVENTMASK, 0&, ByVal ENM_LINK
End Sub
And to respond to a left mouse click you could do the following in your form's subclass routine.
Code:
Private Sub FormSubClass_WMArrival(hwnd As Long, uMsg As Long, wParam As Long, lParam As Long, lRetVal As Long)
Dim notifyCode As nmhdr
Dim LinkData As ENLINK
Dim URL As String
Select Case uMsg
Case WM_NOTIFY
CopyMemory notifyCode, ByVal lParam, LenB(notifyCode)
If notifyCode.code = EN_LINK Then
'A RTB sends EN_LINK notifications when it receives certain mouse messages
'while the mouse pointer is over text that has the CFE_LINK effect:
'To receive EN_LINK notifications, specify the ENM_LINK flag in the mask
'sent with the EM_SETEVENTMASK message.
'If you send the EM_AUTOURLDETECT message to enable automatic URL detection,
'the RTB automatically sets the CFE_LINK effect for modified text that it
'identifies as a URL.
CopyMemory LinkData, ByVal lParam, Len(LinkData)
If LinkData.Msg = WM_LBUTTONUP Then
'user clicked on a hyperlink
'get text with CFE_LINK effect that caused message to be sent
URL = Mid(RTB.Text, LinkData.chrg.cpMin + 1, LinkData.chrg.cpMax - LinkData.chrg.cpMin)
'launch the browser here
ShellExecute 0&, "OPEN", URL, vbNullString, "C:\", SW_SHOWNORMAL
End If
End If
lRetVal = FormSubClass.callWindProc(hwnd, uMsg, wParam, lParam)
Case Else
lRetVal = FormSubClass.callWindProc(hwnd, uMsg, wParam, lParam)
End Select
End Sub
Attached is a project that demonstrates the whole idea.
The DbgWProc.Dll is only used for debugging purposes so doesn't really need to be included, but the author ( Matthew Curland) has given his permission to redistribute it. The file is freely available many places around the iternet.
First off, thanks so much for posting the codes for inserting tables. That's much appreciated!!!
I have access to the control characters for rft documents and what I'd like to do is to have codes that would allow user to change the boarder of the cell that the user's cursor is in (inside a rich text box).
I have searched the net high and low for info. on how to programatically select all the control characters that is associated with that cell and then make modification to them (e.g.: flagging \ckbrdk to false).
Could you kindly help me out with this? I would really appreciate it!
Hi All
I have strange problems with the syntax highlighting programming
No.1 Sendmessage is often out of work
'----------------------Quotation----------------------
LN = SendMessage(RTB.hwnd, EM_LINEINDEX, Byval LineNum, 0&)
'----------------------Quotation----------------------
this works fine in ANSI mode(english text),but when I use UNICODE mode,it returns wrong result as always. I have to seek the preview enter key to locate the fst pos of a line.
No.2
'----------------------Quotation----------------------
.SelStart
.SelLength
.SelColor
'----------------------Quotation----------------------
if selected Line number is under 200,this goes fast,but when it's above 1000,it just stuck over there with a delay of 1 second or more,within these time,the keyboard action might be all in a mess.
Maybe I am confused but I am trying to highlight text on the go without changing the cursor position. Is there anyway to get the RTF text position? Selstart only has it for the standard text and I need the rtf selstart so that I can insert my own colour tags before and after my word.
Just in case your wondering I am writing a script editor and the cursor jumps the box around whenever I highlight words
Thats seems to do it thanks. I had it on the main form hwnd before but changing it to the hwnd of the rich text box itself seems to do the trick thanks
I wish to know how to, uh, well, basically, I am building a chat program for the Hell of it, but want colored text in a RichTextBox. BUT, I dunno how to do it, cause when I try to switch to a color, it ****s up. Ya, so, help?
Using your example I've come to understand how to have text in a richtextbox act as a hyperlink, but given text that looks like this (from which I will strip away the URL tags)
All you need to do is mark the text that you want to attach a hyperlink to with the CFE_LINK Effect. You'll have to keep the URL in a list somewhere so you can respond to user mouse clicks in your WM_NOTIFY event interception.
See my cool spell checker example for how to do this. The spell checker marks all mispelled words with the CFE_LINK effect so that when the user right clicks on it spelling suggestions can be made.
BTW this is much better than RobDogg's simple little spell checker
I just downloaded the clsSpellCheck example and I ran into a problem. When I run it I see the recipe (which I've made previously BTW). I click Spell Check and it underlines all the misspellings. However when I double-clicked one of them nothing happened, so I clicked Spell Check again and got an Invalid property value error in this line
VB Code:
'find each misspelling in the document
For Each spError In WordDoc.SpellingErrors
iPos = mRTB.Find(spError, iPos + 1, , rtfWholeWord Or rtfMatchCase)
[HL="#FFFF80"]mRTB.SelStart = iPos[/HL]
in GetSpellingErrors.
Last edited by MartinLiss; Feb 4th, 2007 at 07:02 PM.
Okay I have the word "this" in my example above formatted with the CFE_LINK effect and I have the associated URL stored in a collection and the richtextbox is enabled for AutoURLDetection. How do I actually get the RTB to open the browser to the stored URL? I assume I have to do something in the RTB's Click event, but what?
The spell checker requires that you right click on a word not double click.
To respond to the user clicking on your hyperlink, see the AutoURL example above.
when text in an RTB has its CFE_LINK effect set, the text will be blue and underlined. More importantly, the RTB will send a WM_NOTIFY message to its parent form for certain mouse operations on the text.
To respond to these messages (such as a left click) you have to subclass the parent form and intercept these messages.
So,
1. see the spell check example to see how to set the CFE_LINK effect for text.
2. See the AutoURLDetect example to see how to bring up the browser (or whatever action) when the user clicks on your special text.
Thanks, I've done all that and I basically have it working. I do have a problem though. Take a look at my post #28. You see that I'm substituting the "Script prompt" that you optionally enter when you insert a hyperlink in a post for the URL itself, so when the user clicks on the underline-blue word I need to tell VB somehow what the URL associated with that word is. I've worked that out by storing both pieces of data in a modified version of your MisSpellings collection and I can now get the browser to open to the correct page. My problem is however, what to do about situations where the same underlined-blue word occurs in more that one place? In that situation there would likely be different URLs associated with them, so what I'd like to do is store some unique, identifying, rtf tag before or after the underlined-blue word where that tag would be the index to the proper entry in the collection. Can I insert things like \'123 into the rtf?
I never received your response to my emails so if you could send me a PM with what you said I'd appreciate it.
My idea is to insert your URL right in the RTF text and hide it with the \v tags.
You can then retrieve this info when the user clicks the adjacent hyperlink.