# VBForums CodeBank > CodeBank - Visual Basic 6 and earlier >  RichTextBox Tricks and Tips

## moeur

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.Highlight textSuperScript and SubScriptInsert tablesInsert PicturesFind and Replace Common DialogSpell Checking classGet Cursor Line and Column PositionDetect and respond to hyperlinksWYSIWYG printing (msdn)Insert Hyperlinked textAdd animated GIF's to your RichTextBox

----------


## moeur

Since there is no .SelHighlight property of the RichTextBox control, I created one.

```
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

```
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
```

----------


## moeur

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.

```
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
```

----------


## moeur

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 twipsxLeft - 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

```
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
```

----------


## moeur

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

```
'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

```
'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
```

Attached is code plus the declares

----------


## moeur

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.

```
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
```

----------


## moeur

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:

```
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!

----------


## moeur

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.

```
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
```

----------


## moeur

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

```
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.

```
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.

----------


## longwolf

Wow, you have some really great stuff here!

But I see one major draw back.
In SpellCheck.zip you have a dll named DBGWPROC.DLL.

Its properties say:
You have a license to use this file only if you have a copy of the book. You may not redistribute this file.

----------


## moeur

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.

----------


## JustinW

Hi:

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!

Thank you in advance!

Justin

----------


## darki

Hi, 

very nice codes...
I found one bug in RTFtable


VB Code:
Public Sub InsertTable(RTB As RichTextBox)
'set column widths
    For c = 1 To mvarColumns
        strInsert = strInsert & "\cellx"
        w = mvarxLeft
        For i = 1 To c
            [COLOR=Red]w = w + mvarclsColumn(c).xWidth[/COLOR]
        Next i
        strInsert = strInsert & CStr(w)
    Next c

If you have all columns same size you can't see difference, but

must be:
*w = w + mvarclsColumn(i).xWidth*

----------


## moeur

Thanks darki

----------


## mamaco

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.

can you give me some suggestion? thx a lot

----------


## BodwadUK

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  :Frown:

----------


## moeur

Probably the easiest thing to do is lock the window while you are doing the highlighting with LockWindowUpdate.


VB Code:
Private Declare Function LockWindowUpdate Lib "user32" ( _
    ByVal hwndLock As Long) As Long
 Private Sub Command1_Click()
Dim iPos As Integer
    'save the current cursor position
    iPos = RTB.SelStart
    'prevent the window from changing
    LockWindowUpdate RTB.hWnd
    'highlight a word
    RTB.Find "is"
    HighLight RTB, vbYellow
    'restore the cursor position
    RTB.SelStart = iPos
    'unlock the window
    LockWindowUpdate 0
End Sub

----------


## BodwadUK

Thanks I shall give it a go  :Smilie:

----------


## BodwadUK

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

----------


## nokmaster

thanks for that tricks..

but how to autoscroll the richtextbox?

----------


## moeur

what do you mean by autoscroll?  What do you want to do?

----------


## nokmaster

@moeur

hi, i mean richtextbox with vertical scroller. if u put this command into command1


VB Code:
with rtb
 .selcolor = vbblack
 .seltext = "ok" & vbcrlf
end with

it will scroll down right? but if you scroll this scroller to up then press the button again it will not scroll.

----------


## BodwadUK

change selstart to the location you want the cursor. It should scroll for you

----------


## nokmaster

> change selstart to the location you want the cursor. It should scroll for you


how?

----------


## BodwadUK

you mean it doesnt scroll down until you hit the bottom of the text window with your cursor?

----------


## Yuji1

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?

----------


## rack

When I try to set the xwidth to 3.5 it dosen't not draw a table, the text is all scambled.

I need the width of each cell to be 3.5inch
I need the Height of each cell to be 2inch
I need there to be 2 columns, with 5 rows.

What is the best way to accomplish this?

EDIT:

I got the width correct, I was using 3.5, when I should have been using Twips, 5040.

How do I do the Height of each cell to be exactly 2inches?  Or 2880 Twips.

----------


## MartinLiss

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)

[ URL=http://www.vbforums.com/showthread.php?p=11111]this thread[/URL ]

how can I get it to look like this? 

this thread

----------


## moeur

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  :Smilie: 

Edit: the link you provided above does not work.

-Bill

----------


## MartinLiss

Thanks for the information Bill. I know about the link; I intentionally made it invalid. BTW, did you get the couple of emails I sent you?

----------


## MartinLiss

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 :Smilie: ). 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.

----------


## MartinLiss

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?

----------


## MartinLiss

I was able to hammer out a way to do it but I'd still be interested in the right way.

----------


## moeur

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.

And I did receive your email and even responded.

-Bill

----------


## MartinLiss

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.

----------


## moeur

Ok I understand your question now.  I thought it was strange that I was having to explain things to you that are spelled out in the example.

Here is an idea:
This \v www.vbforums.com \v0

----------


## MartinLiss

What if there were two URLs and I needed to be able to differentiate them?

----------


## moeur

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.

Does this not work?

----------


## MartinLiss

No, that seems like a great idea! I had no idea (until now) what the \v tag did. Is there a comprehesiuve list someplace of rtf tags?

----------


## moeur

Here is the specification of RTF 1.5
http://www.biblioscape.com/rtf15_spec.htm

Note however that the richtextbox control supports only about 10% of the codes.

I use the vbforums editor to test codes.
Go to View\RTF
Then enter the codes you want to test
Then select View\Normal to see if it worked.

If it didn't work and you go back to View/RTF and the code you entered is gone, then the control does not support it so it removed it.

----------


## MartinLiss

In one of your samples I see this


VB Code:
Public Function PictureToRTF(Pic As StdPicture) As String
What is StdPicture?

----------


## iPrank

StdPicture

VB doesn't open correct page on local MSDN if you press F1 from code window. Open MSDN separately and in the "Index" tab type "StdPicture" to get the offline reference.

----------


## MartinLiss

Thanks.

----------


## iPrank

@MartinLiss, 
RE: *RTB Hyperlink problem*

As the Wordpad of XP (SP2) can display hyperlinks the way you want, I thought may be we should try using XP's rtf dll.
In XP SP1 or later the dll is *msftedit.dll* and the class name is *RICHEDIT50W*. RichEdit version *4.0* (5.0 in XP2 ?).

So, I've created a window of that class and *IT WORKED !*  :Big Grin: 

But creating a RTB from scratch is a very big task.  :Frown: 
vbAccelerator RichEdit Control uses similar method to load Riched20.dll (version 2.0 and version 3.0) library using the LoadLibrary function and create a RichEdit window of that version. So, if we load *msftedit.dll* library, then may be it can create a v4.0 window ?

Unfortunetly, that ocx is not running in my system. Some registry problem.  :Frown:   (this XP installation is damaged). I've worked with this control before. It used to work smoothly.

So, if you try my idea and modify that control's code, I hope it will work. 

BTW, I'm using XP SP2. If the attatched code can't create the window, open Wordpad and get it's classname and try with that class name.

----------


## iPrank

Above method works with VBBox CRichEditCtl.cls
I've used the code inside a usercontrol and it is working.

Now all is left to do is - Modifying properties for this version and Getting the URL. I hope someone can help me on this.  :Big Grin: 

*Edit:*
As far as I can remember, we are not allowed to distribute 'msftedit.dll'. So, even if we create a new RTB control, it will work only in XP.  :Frown:

----------


## MartinLiss

Moeur, I'm using code that I believe I got from your GIFAnimatorV3 project to put smilies in a RichTextbox. I'm using the following code (in part) but when I do the background of the picturebox is not transparent. 


VB Code:
Set GIF = New clsGIF
                With GIF
                    .LoadGIF LoadResData(GIFNumber(mstrSmilies(intTag)), "CUSTOM")
                    ' Clear the picture
                    picSmilies.Picture = LoadPicture
                    .CopyFrame 1, picSmilies.hdc, 10, 10
                    Set picSmilies.Picture = GIF.Frames(1).Picture
                End With
                strRTF = PictureToRTF(picSmilies)
                mstrRTF = VBA.Left$(mstrRTF, mintSmiliePos - 1) _
                        & strRTF _
                        & Right$(mstrRTF, Len(mstrRTF) - (mintSmiliePos - 1 + Len(mstrSmilies(intTag))))
Any hints as to where I can look to fix this?

----------


## MartinLiss

Bill, I've found a serious problem. If you put just the following in a timer (where GIF is member of clsGIF) the app runs out of memory in a minute or so.


VB Code:
With GIF
       .LoadGIF LoadResData(113, "CUSTOM")
        rtbMessage.TextRTF = PictureToRTF(.Frames(1).Picture)
    End With

----------


## MartinLiss

I don't know why the problem occurs, but if LoadGIF is in a timer then memory(?) gets used up and the program crashes. LoadGIF can be removed from the timer and still allow for animation of a smilie, but only _one_ smilie. 

I was able to resolve the problem by doing this

VB Code:
Private GIF() As clsGIF
'instead of
Private WithEvents GIF As clsGIF

You can't do WithEvents with an array but apparently it isn't needed (at least in my code). After that do the following outside of the timer


VB Code:
If UBound(GIF) < the_nbr_of_gifs_to_animate - 1 Then
    ReDim Preserve GIF(UBound(GIF) + 1)
    Set GIF(UBound(GIF)) = New clsGIF
End If
With GIF(UBound(GIF))
    .LoadGIF LoadResData(the_number_of_the_gif), "CUSTOM")
End With
And in the timer


VB Code:
For lngIndex = 0 To the_nbr_of_gifs_to_animate  - 1
        With GIF(lngIndex)
            tmrGIF.Interval = .Frames(1).DelayTime
            mbFrameDisplayed = False
            If iFrame <= .Frames.Count Then
                ' The following line is simplified. In an app you would want to place
                ' the picture somplace within the existing TextRTF rather than
                ' replacing the TextRTF as this does. (PM me for further details)
                MyRTB.TextRTF = PictureToRTF(.Frames(iFrame).Picture) 
                mbFrameDisplayed = True
            End If
        End With
    Next
    If mbFrameDisplayed Then
        iFrame = iFrame + 1
    Else
        iFrame = 1
    End If

----------


## moeur

Marty,

I couldn't reproduce the out of memory error you get, however the solution you came up with is definitely the way to go.  You don't want to have to keep reloading the gif.

----------


## MartinLiss

> Marty,
> 
> I couldn't reproduce the out of memory error you get, however the solution you came up with is definitely the way to go.  You don't want to have to keep reloading the gif.


In the version of my program that I sent you I don't believe that the LoadGIF code at that time was in the Timer.

Have you been able to figure out the non-transparent background problem?

----------


## moeur

OK, try this.  It copies the frame to a picturebox first.  The picturebox background color has been set to the same color as the RTB.
Each time you press the button it loads the next smilie from the resource file.


VB Code:
Option Explicit
 Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Private Declare Function CreateSolidBrush Lib "gdi32" ( _
    ByVal crColor As Long _
) As Long
 Private Declare Function FillRect Lib "user32" ( _
    ByVal hdc As Long, _
    lpRect As RECT, _
    ByVal hBrush As Long _
) As Long
 Private Declare Function SetRect Lib "user32" ( _
    lpRect As RECT, _
    ByVal X1 As Long, _
    ByVal Y1 As Long, _
    ByVal X2 As Long, _
    ByVal Y2 As Long _
) As Long
 Private Declare Function GetSysColor Lib "user32" ( _
    ByVal nIndex As Long _
) As Long
  Dim GIF As clsGIF
Private FrameIndex As Integer
Dim hbrBkgnd As Long
Dim lpRect As RECT
 Private Sub Command1_Click()
Static index As Integer
         GIF.LoadGIF LoadResData(101 + index, "CUSTOM")
        Picture1.Width = GIF.xWidth
        Picture1.Height = GIF.yHeight
        hbrBkgnd = CreateSolidBrush(CheckSysColor(Picture1.BackColor))
        SetRect lpRect, 0, 0, GIF.xWidth, GIF.yHeight
         FrameIndex = 0
        Timer1.Interval = 50
        index = index + 1
        If index = 16 Then index = 0
End Sub
 Private Sub Form_Load()
    Set GIF = New clsGIF
    Me.ScaleMode = vbPixels
    With Picture1
        .BorderStyle = 0
        .BackColor = RTB.BackColor
        .AutoRedraw = True
        .AutoSize = False
    End With
End Sub
 Private Sub Timer1_Timer()
     EraseBackground Picture1.hdc
    With GIF
        FrameIndex = FrameIndex + 1
        If FrameIndex > .Frames.Count Then FrameIndex = 1
        .CopyFrame FrameIndex, Picture1.hdc, 0, 0
        Picture1.Picture = Picture1.Image
    End With
    
    RTB.TextRTF = PictureToRTF(Picture1.Picture)
End Sub
 Private Sub EraseBackground(hdc As Long)
    FillRect hdc, lpRect, hbrBkgnd
End Sub
 Public Function CheckSysColor(ByVal ColorRef As Long) As Long
'sometimes VB colors are expressed as system colors
'we need to change this to an RGB color
   Const HighBit = &H80000000
   If ColorRef And HighBit Then
      CheckSysColor = GetSysColor(ColorRef And Not HighBit)
   Else
      CheckSysColor = ColorRef
   End If
End Function

----------


## MartinLiss

Thanks, I'm working on another issue now and I'll get back to you as soon as I can.

----------


## moeur

OK, here you go.
Here is a sample project that replaces the tags with the proper animated smilie.  The smilies are in gif files so you don't have to mess with resource files.

The project also demonstrates the hyperlink functionality we discussed earlier.  this is because everytime you change TextRTF you have to reenable the EN_LINK effect for the hyperlinks.  Since the animator messes with TextRTF, hyperlinks have to be updated too.

I'm sure there are some bugs and it can be cleaned up a bit but here it is.
Let me know how it works.

----------


## MartinLiss

I'll also check this out but I don't find any problem in my code with animation vs. the EN_LINK effect.

----------


## moeur

> I'll also check this out but I don't find any problem in my code with animation vs. the EN_LINK effect.


Hmm...
I noticed in your code that you do the hyperlinks last.  I assumed this was because if you set them first then changed RTB.TextRTF the blue links would go away.  This is what happens on my system, so each time the animation timer fires and RTB.TextRTF is updated the links need to be reestablished.

----------


## MartinLiss

Your soultion in post #51 works. Thanks!

----------


## MartinLiss

> OK, here you go.
> Here is a sample project that replaces the tags with the proper animated smilie.  The smilies are in gif files so you don't have to mess with resource files.
> 
> The project also demonstrates the hyperlink functionality we discussed earlier.  this is because everytime you change TextRTF you have to reenable the EN_LINK effect for the hyperlinks.  Since the animator messes with TextRTF, hyperlinks have to be updated too.
> 
> I'm sure there are some bugs and it can be cleaned up a bit but here it is.
> Let me know how it works.


That's a very nice example.

----------


## MartinLiss

Bill (or anyone). I sometimes store my TextRTF in a string variable, manipulate the string and then replace the TextRTF with the string. Would you have any idea why when the string contains this

blah blah \v\'10s105\'11\v0 \i0 

it becomes the following in the TextRTF????

blah blah \v\'10s105\'11\i0\v0

----------


## The Midnighter

Why was vbcode turned off in this forum? ._.

----------


## BruceG

This is truly a great thread with loads of useful information. I stumbled upon it when I wanted to see what was involved in setting up a RTB to allow hyperlinks. Great stuff, Bill!

----------


## moeur

In addition to turning a URL you enter into a hyperlink (as in "Auto Detect and respond to URLs" above) you can turn ordinary text into hyperlinked text that points to a URL of your choice.

To do this the text in the Richtextbox has to have its link notification turned on.  Then, as before,  the form containing the Richtextbox has to be subclassed so that you can respond to user actions.  I've created a class that simplifies these tasks.  

This class has two events:*Clicked* - raised when user clicks a hyperlink.
*MouseMove* - raised when the user moves the mouse over a hyperlinkAnd three methods
*Initialize* - called once to attach the RTB to the hyperlink class
*InsertHyperlink* - can hyperlink selected text or insert new text and hyperlink it.
*RefreshHyperlinks* - Unfortunately, whenever the richtextbox's TextRTF property is changed, the RTB will lose all link notification information.  To remind the RTB of previously hyperlinked text you must call this method each time the textRTF property is changed.Here is an example of how to use the class


```
'instantiate and initialize the class
    Dim Hypertext As clsHyperText
    Set Hypertext = New clsHyperText
    Hypertext.Initialize RTB
    
    'hyperlink the word "this" in the Richtextbox
    RTB.Find ("this")
    Hypertext.InsertHyperlink ("http://www.vbforums.com")
```

To respond to user action on the hyperlinks, simply place code in the events.

```
Private Sub Hypertext_Clicked(Button As Integer, URL As String, UnderlyingText As String)
    'launch the browser here
    If Button = vbLeftButton Then
        ShellExecute 0&, "OPEN", URL, vbNullString, "C:\", SW_SHOWNORMAL
    Else
        'popup menu?
        Debug.Print URL, UnderlyingText
    End If
End Sub
```

Attached is a demo project which contains the class.

----------


## moeur

Here is a control that shows you how to add animated GIF images to a Richtextbox.  This control was built to replace VBCode smilie tags with their corresponding animated images.  It takes advantage of my VB GIF Animator Control and the PictureToRTF function in my above post Insert Pictures.

I placed this functionality on a usercontrol because it uses a timer and an array of picture boxes.  The GIFs cannot by placed into the richtextbox transparently, so I change the background of each image to match the background color of the RTB.

The control has two properties*BackColor* - set this property to the backcolor of your Richtextbox to simulate transparency.  This property can only be set from code and cannot be changed once pictures have been inserted into the RTB.

*FrameInterval* - This interval in ms, affects the speed of the animation.two methods*LoadIcon* - load a GIF file and its corresponding tag into the control
*ReplaceTags* - Replaces each tag in the Richtextbox text with its corresponding animated image.and one event*NextFrame* - Raised at each frame advance interval.The following is an example of how you might initialize the control

```
    'set the picture backgrounds to match the RTB background
    GIF.BackColor = RTB.BackColor
    
    'load some icon files along with the corresponding tags
    Path = App.Path & "\icons\"
    With GIF
        .loadIcon ":)", Path & "smile.gif"
        .loadIcon ":(", Path & "Frown.gif"
        .loadIcon ":o", Path & "redface.gif"
        .loadIcon ":D", Path & "BigGrin.gif"
    End With
```

Now to replace all the tags in the RTB text with the proper smilie

```
    GIF.replaceTags RTB
```

Attached is a demo project which illustrates the proper use of this control.

----------


## dee-u

I've got a problem with insertion of rtf, when the text in the target rtb control is colored and the text/rtf being inserted has some colors also, when inserted the color of the inserted rtf is lost... :-(  Any workarounds there? :-)

----------


## moeur

what do you mean by "insertion of rtf"?

----------


## dee-u

Using your function to insert. :-) For instance, if the target rtb control got some colored text then the rtf being inserted got some colored text also, the color of the rtf being inserted is overridden, the color table is not updated... :-(

----------


## moeur

what you're saying still does not make sense to me.
what do you mean by my function to insert :-) ?
Do you mean inserting an animated GIF?  If so then how can that have colored text?

Please explain in detail or supply example code.

----------


## MartinLiss

I think he just means that if for example a RichTextBox is red and you pasted red text into it the text could not be seen.

----------


## dee-u

> what you're saying still does not make sense to me.
> what do you mean by my function to insert :-) ?
> Do you mean inserting an animated GIF?  If so then how can that have colored text?
> 
> Please explain in detail or supply example code.


For example, the ff. is the tex of the target rtb: *dee-u*

And the text being inserted is: m*o*eur

If you will try to insert the rtf of moeur to the rtf of dee-u then the colors of meour is not preserved, it is being overridden. Clear now? :-)

----------


## moeur

Not clear,

I still don't know how you are trying to insert text.
why don't you just show me the code you are using to insert text?

----------


## dee-u

Ok, here is further explanation since I don't have VB6.0 here.

RichTextbox1 control has the 'dee-u' text (with the colors as in my previous post), RichTextbox2 control has the 'moeur' text (with the colors as in my previous post), get the TextRTF of Richtexbox1 then insert it, using your function to insert rtf, in the RichTextbox2, perhaps in the middle of 'm' and 'o'.... The color of 'dee-u' will be overriden... :-(

I hope I made myself clear already.... :-)

----------


## moeur

After asking 3 times.
I give up.

If you want to supply code mabye I can help.

----------


## dee-u

Ok, have a look at the attached form... :-)

----------


## moeur

works ok for me.
Maybe you have an outdated version of the Richtextbox control.

----------


## MartinLiss

When you click the button and move "dee-u" to rtb2, dee-u takes on the colors of rtb2 rather than maintaining the colors it had in rtb1.

----------


## dee-u

> When you click the button and move "dee-u" to rtb2, dee-u takes on the colors of rtb2 rather than maintaining the colors it had in rtb1.


Yup, that is what I am trying to tell...  :Smilie:

----------


## moeur

The simplest way to do what you want to do is this

```
RTB2.SelRTF = RTB1.TextRTF
```

----------


## aikidokid

Moeur, thanks for all of this, it's great and alot of it is what I have been looking for, although I don't confess to totally understand all of the code.
I am working through it slowly.  :Wink: 

I have used the hyperlink code and there are a couple of question I have:

Firstly, I would only like to enable the autourldetect under certain circumtances. How can I turn it off?

Secondly, if there is a link in the RTB, if I click anywhere in the RTB it opens the link. Is this how you planned it?
I have other text in the RTB which I would be editing and when I click somewhere in the RTB, it opens the link.

If the non-link text is first in the RTB it's ok, but if I click anywhere after the link, where there is no text, just space, it still selects the link and opens the link.

I hope you can follow what I am trying to explain.  :Roll Eyes (Sarcastic):  
I have just done a straight copy of your code in the example project, with the exception of this line which is not in the Form_Load, but in a treeview node_click.

vb Code:
EnableAutoURLDetection RTB

----------


## aikidokid

I have now used the following to turn off the detection.
I just wondered, being new to subclassing, is this ok, or do I need anything else.
It seems to work ok.  :Big Grin: 

vb Code:
Public Sub DisableAutoURLDetection(rtb As RichTextBox)
 Set FormSubClass = Nothing
 End Sub

----------


## moeur

try this instead

```
Public Sub DisableAutoURLDetection(RTB As RichTextBox)
    'disable auto URL detection
    SendMessage RTB.hwnd, EM_AUTOURLDETECT, 0&, ByVal 0&
    'turn off subclassing
    FormSubClass.Unsubclass
End Sub
```

As to your other problem:

I only see this when the hyperlink is the very last text in the richTextBox.  This is a bug in the richtextbox itself.  To eliminate this problem, put something after the hyperlink even just a new line.

----------


## aikidokid

> try this instead
> 
> ```
> Public Sub DisableAutoURLDetection(RTB As RichTextBox)
>     'disable auto URL detection
>     SendMessage RTB.hwnd, EM_AUTOURLDETECT, 0&, ByVal 0&
>     'turn off subclassing
>     FormSubClass.Unsubclass
> End Sub
> ...


Thanks moeur.

I will change the Disable code.
Is this to change the message from the RTB back to, I guess the form?

I eventually realised that the way to do this was to put the link first, then the text afterwards.  :Big Grin: 

Thanks for all your hard work.

----------


## aikidokid

I am trying to adjust you code to make it an option that can be turned on/off.

If the user opens the Options form and changes the option from Enabled to Disabled, I am getting the error:
_Object variable or With block variable not set._
on this line:

vb Code:
FormSubClass.Unsubclass
I know what this means, but I'm not too sure how to change this.

This is because, even if the Enabled option is selected, I don't use this line until certain conditions are met:

vb Code:
EnableAutoURLDetection RTB
so the RTB hasn't yet been subclassed.

Is there some way of checking if the subclassing has happened before I fire this line of code?

vb Code:
FormSubClass.Unsubclass

Such as


```
If Not FormSubClass.Unsubclass Then ....
```

----------


## moeur

Actually there is a very simple solution:
Take the line

```
Set FormSubClass = New clsSubClass
```

from out of the EnableAutoURLDetection subroutine and put it into the Form_Load Event.

----------


## P_Presland

Hi

I am very new to VB6 so please bear with me.

I have used your Auto URL Detection within my program. When i downloaded your file it worked fine on its own, but as soon as I have intergrated it with mine I seem to have broken it.

My program still work as it did, and the url changes to a hyperlink where expected, the only bit which does not work is th clicking of the url.

Can you look over what I have done and see what you make of it

Thanks

----------


## MartinLiss

I can't run your project because MISUIUtilities.ocx, modCallBack.Bas and clsSubclass are missing from the zip file.

----------


## P_Presland

Sorry

Give me a couple of minutes and i'll repost with them

----------


## MartinLiss

If MISUIUtilities.ocx is something that you purchased then you shouldn't post it.

----------


## P_Presland

Martin
Thanks for your offer of help. What a great site you have got here.

I have rewritten this part of my program in a single form removing it from my main program in order to send to you for help and in so, I have resolved my issue.

I have changed my program to look at the SQL Northwind default database. If you change a couple of the records within the orders table on the "Shipname" field to be a url then this seems to work fine.

I have attached for others to view. 
If you are going to look at the attached please be aware that my coding maybe a little rough around the edges

----------


## P_Presland

Attachment

----------


## Medsci

I just wanted to add my thanks for some really great tips and also to point out that in post #3, line 8 of SetSuperScript is:

.SelText = Chr(&H9D) & .SelText & Chr(&H80)

However, unless I change this to:

.SelText = Chr(&H9D) & .SelText & Chr(&H81)

It behaves strangely.

Thanks again

----------


## Tom Moran

Thank you for these great RTB tips.  I have been using the Tables code you provided.  As I'm sure you're aware, there are two basic wrappers for RTB control... riched32.dll and riched20.dll.  The tables code behaves differently depending on the wrapper being used.  The problems I've noted are:

1.  Text that wraps in a cell does not display properly if riched32.dll (default) is being used.  It displays correctly with the newer riched20.dll (ver 4+).

2.  The grid lines of a table created with your code does not print with riched20.dll but does with the older riched32.dll.

Since MS WordPad uses the riched20.dll (disguised as msftedit.dll) and since the tables format correcly, I too prefer that version.  My question is...  is there a way to have the grid lines print?

Thanks, again for your insight and very helpful code!

Tom

----------


## scmay

> 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:
> 
> ```
> Option Explicit
> Private SpellCheck As clsSpellCheck
> 
> Private Sub cmdSpellCheck_Click()
> ...




Hi there, wanted to try your spell checker but faced some strange issues. I copied over your libraries and imported your form, but for the same actions I am getting error at GetSpellingErrors() 

For Each spError In WordDoc.SpellingErrors

Error 13 Type mismatch

whenever there is a misspelled word. If there are no errors, the program works fine. This error only happens to the new 'copied' project, does not happen in your program.

I have added the components and references, even the dll even though I don't think that is needed. I have added the error image attachment here for clearer understanding (if I had not made myself clear)

Am I missing something?

----------


## mobileFX

Dear all,

Has anyone deviced any method / subclass trick for actually changing the default blue color of the RTF EN_LINK hyperlinks? I mean, if I want to display a red hyperlink, is this possible?

In my research I tried using GetSystemColors and SetSystemColors with index value 26 (Hyperlink) but it seems to have no affect of RichEdit.

----------


## pro2c

Hello!

Thank you very much for the code for the tables in richtextbox, it's the only available on the internet. Unfortunatly i'm using vb.net 2005 and can't convert it correctly to use it in my app. Do you have any library for .net?

Regards

----------


## Nitesh

Hi moeur,

I ran into an issue. If I enable the autourldetection the selchange event doesn't fire so the line and columns dont get updated in the statusbar as I move the cursor

----------


## moeur

I did verify the problem you see.  This is a problem with the Richtext box which we have no control over.  But, there is a simple fix:
Place the code that is in the SelChange Event in both the RTB_Click and RTB_KeyUp events.

----------


## bim11

Hi moeur

Your code is great for inserting pictures into the rich textbox.

However, i am able to move the images around and resize them. I dont want them to be resized/moved around.

How can you stop pictures from being moved and resized?

(NOTE: The locked property of the rich textbox is useless to me, because if Locked is set to TRUE, then you cant even type in the rich textbox).

----------


## Doogle

Hi moeur,

I think you can solve a little problem for me, back in May last year and in another Forum, I was struggling to help someone who wanted something like a ProgressBar but with text inside it (they were building a Browser and wanted to do like Firefox, I think, the Progress was displayed where the URL was typed.) Anyway, I came up with a RichTextBox solution:


```
Option Explicit
'
' Example of manipulating RTF in a RichTextBox
' to simulate a 'ProgressBar' with imbedded text
' (Based on some code I found on the Internet somewhere)
'
' Requires:
' Command Button (cmdGo)
' RichTextBox (rtb1)
' Timer (Timer1)
'
' Tested on XP SP2 and it seems to work OK
' Tested on Windows ME and doesn't work
'
Private boFinished As Boolean
Private strOriginalRTF As String

Private Sub cmdGo_Click()
'
' Simulates starting something going
'
Timer1.Enabled = True
End Sub

Private Sub Form_Load()
Timer1.Enabled = False
Timer1.Interval = 500
rtb1.Text = "This is some text"
End Sub

Private Sub Timer1_Timer()
'
' Simulates 'progress'
' Triggers once every half second
'
boFinished = UpdateProgress(1)
If boFinished = True Then
    Timer1.Enabled = False
    rtb1.TextRTF = strOriginalRTF
    rtb1.SelStart = 0
    rtb1.SelLength = 0
End If
End Sub
Private Function UpdateProgress(intColour As Integer) As Boolean
'
' Progressively change the background colour of
' each character in the RichTextBox to intColour
' Achieved by inserting RTF codes to define a ColorTable
' and highlight the selected text.
'
' Returns True when all characters have been processed
'
Dim strColour As String
Dim strRTF As String
Static intEnd As Integer
UpdateProgress = False
'
' Save the original TextRTF so it can be
' re-set later, increment the character position
' and check if we've finsihed yet
'
If intEnd = 0 Then strOriginalRTF = rtb1.TextRTF
intEnd = intEnd + 1
If intEnd <= Len(rtb1.Text) Then
    '
    ' Select the appropriate number of characters
    ' and make sure they don't appear highlighted
    ' by the selection
    '
    rtb1.SelStart = 0
    rtb1.SelLength = intEnd
    rtb1.SelColor = rtb1.BackColor
    '
    ' Convert the colour to RGB form
    ' and insert leading zeros if required
    '
    strColour = Hex(QBColor(intColour))
    strColour = String(6 - Len(strColour), "0") & strColour
    '
    ' Now build our RTF:
    '
    ' ColorTable:
    '
    strRTF = "{{\colortbl;"
    strRTF = strRTF & "\red" & CInt("&H" & Right(strColour, 2))
    strRTF = strRTF & "\green" & CInt("&H" & Mid(strColour, 3, 2))
    strRTF = strRTF & "\blue" & CInt("&H" & Left(strColour, 2))
    strRTF = strRTF & ";}"
    '
    ' Highlight:
    ' This is the RTF Code used to cause the change in
    ' colour. It uses our ColorTable (Number 1)
    ' (I can't seem to find any documentation on this
    ' code but if it works then ....)
    '
    strRTF = strRTF & "\highlight1 "
    '
    ' Finally the actual text and closing RTF brackets
    '
    strRTF = strRTF & Mid(rtb1.Text, 1, intEnd)
    strRTF = strRTF & "}}"
    '
    ' Set the RTF of the selected characters to our
    ' codes
    '
    rtb1.SelRTF = strRTF
Else
    '
    ' We've finished
    '
    UpdateProgress = True
    intEnd = 0
End If
End Function
```

Was it, perhaps some of your code I stumbled upon. The 'highlight' thing has had me confused for a long time !!

----------


## brianbird

Thanks so much for posting these helpful RTB functions. I would like your permission to use modRTFpic.bas in a commercial application. How would you like me to credit you in the comments?

----------


## Philly0494

> Thanks so much for posting these helpful RTB functions. I would like your permission to use modRTFpic.bas in a commercial application. How would you like me to credit you in the comments?


This was posted in 2007, so he might not still be active, plus since he posted it here he is giving everyone permission to use it, its open.

So give him credits if you want but its not required - at least i dont think so

----------


## Xancholy

I have a unique question that may compliment this thread.

I need to highlight a line in a richtextbox only if "*line starts with*" mystring...

The code needs to fire as user is typing...

I store my search strings and unique highlight colors thus:


```
    Dim searchword() As String = {"fox", "dog", "cat", "horse"}
    Dim ItemBkColor() As Color = {Color.Yellow, Color.LightYellow, Color.PaleVioletRed, Color.LightSeaGreen}
```

Please can you show me how to code the richtextbox events to catch this scenario ?

Thanks

----------


## MartinLiss

The code in this thread refers to VB6 while you seem to be asking about VB.Net.

----------


## pannam

hi moeur i am using your modRTFpic.bas in my server/client to handle smilies.it is working fine in the send part but while receiving i get a code such as 

```
{\pict\wmetafile8\picw503\pich503\picwgoal285\pichgoal285 
010009000003fe0200000000dd02000000000400000003010800050000000b0200000000050000
000c0213001300030000001e00dd02000040092000cc0000000000130013000000000028000000
130000001300000001000800000000007c01000000000000000000000000000000000000217b9c
00297b9c001842a5002142a500a5a5a500ada5a500a5ada5002142ad00a5a5ad002952b500298c
b5004a94b5005294b5003963bd002994bd00319cbd00639cbd0063a5bd006ba5bd00bdbdbd00bd
c6bd00c6c6bd002994c60063adc6006badc600bdc6c600c6c6c6009cbdce00cecece00d6cece00
21a5d60029a5d60029add6006bb5d60094bdd6009cbdd6009cc6d60029a5de0021adde0029adde
009ccede00a5cede0031a5e70029ade70021b5e70031b5e70031bde7006bbde70039c6e700c6de
e700cedee70021b5ef0029b5ef0029bdef0031bdef0029c6ef0052c6ef0073ceef007bceef00ad
d6ef00c6d6ef00addeef00cee7ef0018b5f70021b5f70021bdf70031c6f70052c6f70073c6f700
39cef70073cef70031d6f70039d6f7007bd6f700addef7007be7f700cee7f70031ceff0042ceff
0031d6ff0039d6ff0042d6ff0039deff0042deff00addeff0042e7ff004ae7ff00ade7ff00b5e7
ff004aefff0052efff00b5efff00ceefff00d6efff004af7ff0052f7ff005af7ff00d6f7ff00de
f7ff00f7f7ff005affff00d6ffff00f7ffff00ffffff00ffffff00ffffff00ffffff00ffffff00
ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff
00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ff
ffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00
ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff
00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ff
ffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00
ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff
00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ff
ffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00
ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff
00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffff
ff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ffffff00ff
ffff00ffffff006767676667663e29180b12243266666767676700676767673e211f2533342b1e
16103167676767006767663b203503030303030303200a236667670067673d2d42031367671c67
671303400f1b676300675c2d5003671367671c6767136703400e3c67006644480304671367671c
6667136708032711630061370304041413131c1c1c1315130404030e32004a5003670467146767
1c676613670467031f22003953036705671367671c676713670467032b12003859036704661367
671c66671367046703330c0049560d030303030303030303030303030934180057532a5f5f5a5a
605a5a59555252484d0d20280062505a606060605a5f5a5a5a5556534d421f3e00664956605201
0101115f110101013050362166006761485f016060605e5a5a5a55560150204c67006767585360
60605f605f5a595655532e3b6767006767665848595f605f5a595a55512e3d6766670067676766
61494e56565a594845395c6767676600666767676763614a49383a4a5d63676766676700040000
002701ffff030000000000
```

 instead of the smileys ..where am i going wrong ?:s

----------


## moeur

I would have to see the relevant sections of your code to be of any help.

----------


## pannam

> I would have to see the relevant sections of your code to be of any help.


here , i have uploaded a rough project . i can send smileys from my server to the client and out put them on a textbox but when i send smileys and a message together i am not able to output smileys :Frown:

----------


## moeur

Sorry,

I don't see where you are using my code.
Perhaps you should talk to the hand.

----------


## pannam

> Sorry,
> 
> I don't see where you are using my code.
> Perhaps you should talk to the hand.


i got it solved (a silly mistake) .A big thanks to you, as this post got me started and i learned a lot from this post and your project as well ..all in all i got so confused i uploaded a different project .sorry .
lastly ,
great work
 :Thumb:   :wave:

----------


## Dugor

Is there anyway to change the color of the link?

----------


## moeur

Not that I know of.

----------


## Antithesus

moeur, thanks for all your work and these valuable tips.

I am trying to create a module which will actually create a RTF file (document).
To do this, I am writing RTF control words and codes out to the file.
I am able to do it for plain text, and colored text, and pictures/images,
and lines and rectangles.

But for ROTATED text (text which is NOT horizontal, but lies at an angle on the page), I am bumping into a brick wall.

I have been able to "sort of" solve this by creating a temporary picture object with the rotated text in it, then writing that picture out to the RTF.
This works, but it is somewhat clumsy... and my determination of the picture dimensions, based on the angle of text rotation is really clumsy.

So I am looking for an alternative.

I am looking at the code details of an RTF file which has rotated text in it.
It uses a "shape", and then inserts a long string of hex data after all the appropriate codes. And this does it just fine.

So, to my question,
do you have any further info on the format/content of the hex string which I might be able to use to employ this solution, rather than my picture box ?

I enclose a direct copy/paste of the rtf file which contains the "shape" code and which seems to work.



```
{\shp{\*\shpinst\shpleft0\shptop0\shpright32000\shpbottom32000
\shpfhdr0\shpbxpage\shpbypage\shpwr3\shpwrk0\shpfblwtxt0\shpz0\shplid1025
{\sp{\sn shapeType}{\sv 75}}
{\sp{\sn fFlipH}{\sv 0}}
{\sp{\sn fFlipV}{\sv 0}}
{\sp{\sn pib}{\sv 
{\pict\wmetafile8
0100090000038200000002001C00000000000400000003010800050000000B0200000000050000000C02007D007D1C000000FB023DFF00007A0D7A0D90010000000000100000417269616C00A775440F0AA2709F740730CA120010DAA475C060A775610F66A7040000002D010000050000000902FF8000001A000000210527002E205072696E7420707265766965772069732074686520626573742C20616E676C6520333435B00050195019050000000902010000001C000000FB021000070000000000BC02000000000102022253797374656D0000610F66A700000A0022008A0100000000FFFFFFFFBCCA1200040000002D01010004000000F0010000030000000000
}}}
}
}
```

The hex in red is the actual string displayed....
"Print Preview is the best, angle 345 [code for 'degrees']",
and the color is sort of "orange".

I need to know what all the code leading up to, and following that text is.

I have searched high and low, but just can't seem to find anything.

Can you help me, please.

Thanks

----------


## Merri

Search for Windows Metafile. Afaik the hex presentation is just a regular data of a WMF file.

----------


## jmsrickland

The file MISUIUtilities.ocx is still missing from your two zip files posted in #83 and #88.

----------


## PMad

Is there a way to prevent users from resizing the images when they are inserted into a RTB?

----------


## quijotemx

I don't get the following code perform correctly:


vb Code:
Private Sub text2ADDText(xText As RichTextBox, fontN As String, fontS As Integer, fontI As Boolean, fontU As Boolean, fontB As Boolean, txt As String)
    Dim text2Len As Long
        
    text2Len = Len(xText.Text)
    xText.Text = xText.Text & vbCr & vbLf & txt
    xText.SelStart = text2Len + 2
    xText.SelLength = Len(txt)
    xText.SelBold = fontB
    xText.SelUnderline = fontU
    xText.SelFontName = fontN
    xText.SelFontSize = fontS
    
End Sub

It only produces the desired result in the last line added to the control invoking the sub.

Could you help me ...


El quijoteMx

----------


## Edgemeal

> I don't get the following code perform correctly:


Is this any better?


```
Private Sub AppendText(RTB As RichTextBox, _
                fontN As String, _
                fontS As Integer, _
                fontI As Boolean, _
                fontU As Boolean, _
                fontB As Boolean, _
                NewText As String, _
                Optional TextColor As Long = vbBlack)

    With RTB
        .SelStart = Len(.Text)
        .SelColor = TextColor
        .SelBold = fontB
        .SelItalic = fontI
        .SelUnderline = fontU
        .SelFontName = fontN
        .SelFontSize = fontS
        .SelText = vbCrLf & NewText
    End With

End Sub
```

----------


## fsossaco

moeur:
I downloaded your program to make tables in RichTextBox. 
I am using It in a program I'm developing; when I run my program It writes the new table, but It repeats the table that was in the RichTextBox. How do I delete the first table and show only the new table?

This is:



   1	   UNO       	   2	   12	   5	   5	
   3	   TRES      	   2	   7	   4	   5	
   5	   CINCO     	   2	   12	   5	   5	
   6	   SEIS      	   2	   12	   5	   5	
   7	   SIETE     	   2	   12	   5	   5	
   25	   25        	   2	   12	   5	   5	
   40	   40        	   2	   4	   4	   5	
   41	   41        	   2	   12	   5	   5	
   42	   42        	   2	   12	   5	   5	
   43	   43        	   2	   12	   5	   5	
   44	   CUATROCUAT	   2	   10	   4	   5	
   45	   CUATROCINC	   2	   12	   5	   5	
   46	   CUATROSEIS	   2	   4	   4	   5	
   47	   CUATROSIET	   2	   12	   5	   5	
   48	   CUATROOCHO	   2	   12	   5	   5	
   49	   CUATRONUEV	   2	   7	   4	   5	
   50	   CINCUENTA 	   2	   8	   4	   5	
   51	   CINCOUNO  	   2	   11	   5	   5	
   52	   CINCODOS  	   2	   10	   4	   5	
   60	   60        	   2	   12	   5	   5	
   61	   61        	   2	   5	   5	   5	



   1	   UNO       	   2	   12	   5	   5	
   3	   TRES      	   2	   7	   4	   5	
   5	   CINCO     	   2	   12	   5	   5	
   6	   SEIS      	   2	   12	   5	   5	
   7	   SIETE     	   2	   12	   5	   5	
   40	   40        	   2	   4	   4	   5	
   41	   41        	   2	   12	   5	   5	
   42	   42        	   2	   12	   5	   5	
   43	   43        	   2	   12	   5	   5	
   44	   CUATROCUAT	   2	   10	   4	   5	
   45	   CUATROCINC	   2	   12	   5	   5	
   46	   CUATROSEIS	   2	   4	   4	   5	
   47	   CUATROSIET	   2	   12	   5	   5	
   48	   CUATROOCHO	   2	   12	   5	   5	
   49	   CUATRONUEV	   2	   7	   4	   5	
   50	   CINCUENTA 	   2	   8	   4	   5	
   51	   CINCOUNO  	   2	   11	   5	   5	
   52	   CINCODOS  	   2	   10	   4	   5	
   60	   60        	   2	   12	   5	   5	
   61	   61        	   2	   5	   5	   5	


Thanks You.
fsossaco
{Email removed}

----------


## ItsDaniel

Does Anybody Know How To Make Bold Writing In A Rich Textbox?
I Have Tried Lots Of Ways But Just Cannot Seem To Find One.

Cheers Daniel

----------


## si_the_geek

Welcome to VBForums  :wave: 

I'm afraid you are in the wrong forum - this one is for VB6 and earlier, and according to your profile you are using VB2008, which is VB.Net

You may be able to find a thread like this in our CodeBank - Visual Basic .NET forum which contains the answer.  If not, try asking in our VB.Net forum.

----------


## ycdbsoya

Thanks for the great RTB tips.

I'm trying to get the spell check to work, all is OK except for right-click to display menu of suggestions. I think this is because all my RTBs are within various pages of SSTab controls on my forms, so the RTB's parent is not the form itself.

I tried some basic changes to clsSpellCheck, such as hard-coding frmxxxx.hwnd rather than mRTB.Parent.hwnd, but with no success.

Am I wasting my time trying to do this with RTBs contained within SSTabs rather than directly within the form?

----------


## Mama Sylvia

The code is really neat and it works.
Unfortunately it disables the RTB's Change and SelChange events, and I need at least the Change Event to enable the Save button in my Toolbar and to ask for to save changes on exit.
Any solutions?

----------


## Merri

KeyPress and tracking text length between saves/status checks should work for you. The only case it won't work is when someone pastes and cuts texts of exact length by using mouse only. I'd say that is pretty rare. If you use a custom context menu or disable it then this too becomes a non-issue.

----------


## Mama Sylvia

Thanks Merri,

the Key... events still work, but they are in no way an easy to use substitue for the SelChange event. "tracking text length" won't do me any good if a text portion replaced is as long as the replacement. And in no way do the Key... events reflect any toolbar activities. These activities will also have to be monitored.
I came to the conclusion to do it without the hyperlink feature for now, rather than programming massive workarounds to compensate the disabled Change and SelChange events, unless - either somebody has a soution to have both the feature and the Change events or I find a reasonable workaround.

What I don't quite understand: Exactly which part of the hyperlink feature disables these events and why?

So there'll be no misunderstanding: I'm refering to http://www.vbforums.com/showthread.p...70#post2186470, which was submitted by moeur.

Regards

----------


## Tom Moran

Yes it does interfere with the messages being sent by Windows to the Rich Text Box.

There is a work around for this with a function named RichWordOver.  You can see how it works by downloading this code from PSC:

http://www.planet-source-code.com/vb...69067&lngWId=1

When loaded in your IDE do a search on URL and you will see the associated code and even comments on the fact of interference.  I think you'll be able to see what's happening and how to make it work but if you have any specific questions let me know.

Tom

----------


## Mama Sylvia

Thanks Tom,

I've downloaded the ZIP and will get into that later.

Regards
Sylvia

----------


## amolpatil

Hi,
  I tried code for inserting picture into rich text box. It works only for small bmp/jpg files but if bmp is little complicated the program hangs up. Can u tell me the solution.

amol

----------


## Merri

*Update!* See post #137 for the fastest version.


This should work faster:

```
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 HexHigh As Byte, HexLow As Byte
    Dim fn As Long, i As Long, j As Long

    sTempFile = App.Path & "\~pic" & ((Rnd * 1000000) + 1000000) \ 1 & ".tmp"  'some temprory file
    If LenB(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(0 To nBytes - 1)
    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 = UBound(ByteArr)
    ReDim Preserve ByteArr(i * 4 + 3)
    ' turn one byte to two characters to represent a hex number (1 byte -> 4 bytes)
    For i = i To 0 Step -1
        ' take 4 bits from each side of the byte thus giving a value of 0 - 15
        ' and then add character code of 0
        HexHigh = ((ByteArr(i) And &HF0) \ &H10) Or &H30
        HexLow = (ByteArr(i) And &HF) Or &H30
        ' correct characters over 0 - 9 range to a - f range
        If HexHigh > &H39 Then HexHigh = HexHigh + 39
        If HexLow > &H39 Then HexLow = HexLow + 39
        ' create the string
        ByteArr(i * 4) = HexHigh
        ByteArr(i * 4 + 1) = 0
        ByteArr(i * 4 + 2) = HexLow
        ByteArr(i * 4 + 3) = 0
    Next i
    
    'string we will be inserting
    retStr = headerStr & CStr(ByteArr) & vbCrLf & "}"
    PictureToRTF = retStr
    
    'remove temp metafile
    Kill sTempFile

End Function
```

Tested now.

----------


## Mama Sylvia

> Hi,
>   I tried code for inserting picture into rich text box. It works only for small bmp/jpg files but if bmp is little complicated the program hangs up. Can u tell me the solution.
> 
> amol


Hi amol,
as stupid as this may sound: The solution is - don't load any large BMPs or other large images into a RTF box, as it takes too long and may seem that the program hangs up. You're not just loading an image, you're also storing the pre-imageloading status somewhere (the RTF box does this by design) so you can make an Undo (usually with Ctrl+Z).
Sorry.

HAND
Mama Sylvia

----------


## amolpatil

Thanks Merry.

ref:- inserting picture into rtf.

But it gives error for many statements like

 retStr = headerStr & ByteArr & vbCrLf & "}"  <- Type mismatch

 If I comment that line for instance then it gives "out of subscript" error for

 ReDim Preserve ByteArr(i * 4 + 3)

 Sorry. Although i am programming with vb6 for many years. I never worked with graphics (because it is not required till now) . So please bear with me
and help me out.

----------


## amolpatil

Hi 

  My another question is "Can U wrap text around picture ? " . Is it possible ? I know some commercial controls like "tx-text edit control" can do that. But they are very costly to purchase

Thanks

Amol

----------


## Merri

Fix: retStr = headerStr & CStr(ByteArr) & vbCrLf & "}"

----------


## amolpatil

Thanks Merry.

 But the code is still having problems. I fixed some of them. I dont know whether it is correct or not.

like for 
  ReDim Preserve ByteArr(i * 4 + 3) it gives "subscript out of range " error
 b'coz before that it was redeemed as

 ReDim ByteArr(1 To nBytes). so i fixed it to ReDim ByteArr(0 To nBytes)

 then the program runs without any error until last statement. but instead of picture in rtf box it returns rtf string. Attaching my code herewith. 

Amol

----------


## Merri

I fixed the earlier code.

----------


## silkworm

Hello *moeur* and all other friends around here,

(... If you are too busy to read the whole thing, you may skip the intro and start to read below the line.)

I know this thread is five years old, and maybe many of you moved on, but I am still using the good old VB6.

I am working on an app that generates a monthly report using a RTB.
Since most ot the text is the same (only the header and some numbers are changing), i have a template .rtf file which I load, already formatted as I want, with some tags like " $date , $stocks , $qty , $total" that I change by search&replace, totally "invisible" to the user.

But I found a problem with the header: since it has a logo in the left, and four-lines of text in the right (company name, the address on two lines of text, and a phone number on the fourth line), it should be displayed this way, but it seems that there is no way to force such alignment on RTB, not even using tables (only a single row can be displayed next to the image, all the other are displayed below the image).

So I thought I could resolve this problem by transforming the four lines of text into images, and combining it with the logo into a single image, which was not hard for me to do, since I already have the code for it (I used it in an old app in the past).

Next, I need a way to insert that image into RTB; I found many ways that had to do with the clipboard, but since I didn't want to alter the clipboard data, I searched furthermore and I found your method from post #5.

The only problem was that with an image of 417x153 pixels (about 190 KB), your code was painfully slow, it took several minutes on a laptop with Core2Duo CPU 1.4 Ghz with Windows 7 (running on AC, not on battery power)... perhaps in Windows XP is faster, since it doesn't have to execute the 32-bit code in "wow" mode.

So I began to debug and examine carefully your code to see what piece makes the process so slow, and what can be improved.
And I found the problem: you have one line of code: " byteStr = byteStr & Hex00(ByteArr(i)) "  which makes this proces soo slow; it seems that huge string operations in VB6 are painfully slow.
___________________________________________________________
That's why I need a way to avoid this slow process, so I approached the method in a different way.
Instead of keeping a single string that will add values again and again, I preffered to use an array with smaller strings ( * 2 ), which whill then be joined together. In the end, I obtained the same result, but coded differently, since the Join function is a native VB6 function and thus is very fast.

Moreover, I altered the way you transform a byte to its corresponding hex (string) value. Instead of calling the Hex function thousand of times (more than 190.000 in my case), I created an array of 256 strings * 2, in which I pre-loaded the corresponding hex values of the 256 bytes (0 to 255), which are already in lower case and with a leading zero for the first 16 bytes, so many functions are called only 256 times now: Hex, Hex00, Lcase, and Right - in the routine for inserting the leading zeros.

So, the modified code has the following advantages:
 we don't need to call Lcase to such a huge string, since our array with hex values are already in lower-case; we don't need to call Hex00 function (for Leading Zeros) thousands of times, just 256 times; huge strings operations in VB6 are very slow, so we use a faster way to concatenate the little strings; the whole process takes less than a second for an image of the size mentioned above, while it took several minutes before.
This was the old code:


```
    '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
```


*And this is the new code:*


```
    ' make an array with all byte-to-hex values (256 total values)
    Dim hx(255) As String * 2 ' array is always faster than calling a Function and getting its result
    For i = 0 To 255
      hx(i) = LCase(Hex00(i))
    Next i
    
    'turn each byte into two char hex value
    ' byteStr = ""  -- we don't need this variable anymore
    ' We will use a huge array instead of a huge string, in order to keep all of our bytes-to-hex transformations
    ReDim qx(nBytes + Int(nBytes / 40) - (nBytes / 40 = nBytes \ 40)) As String ' thus, UBound = nBytes + nBytes/40 if nbytes divides by 40, otherwise, UBound = nBytes + nBytes/40 + 1
    ' Note: We cannot use fixed length-strings ( String * 2 ) in the qx array, since fixed length strings cannot be joined
    j = 0
    qx(0) = vbCrLf
    For i = 1 To nBytes
      j = j + 1
      qx(j) = hx(ByteArr(i))
       If i \ 40 = i / 40 Then
         j = j + 1
         qx(j) = vbCrLf
      End If
    Next i
    If nBytes \ 40 = nBytes / 40 Then qx(j) = vbCrLf  'if nBytes divides by 40, then don't add another CR/LF, because it was already added in the For...Next above
    
    'string we will be inserting
    retStr = headerStr & Join(qx, "") & " } "
    PictureToRTF = retStr
    
    'remove temp metafile
    Kill sTempFile

End Function
```

*NB:* if you have Option Base 1, then change "Dim hx(255) as String *2" to "Dim hx(0 to 255) as String * 2"

I though It will be good to post the results, so other people can take the benefit of it.

Although I write programs in VB for many years now, I am not a such a VB expert as you are, but I am obsessed with optimising the code, so, instead of adding a progress bar, I preffer to see what is causing the slow-down.

Your method of adding a picture into RTB is by far the best I found... it only needed slight improvement  :Smilie: 

Please excuse my English, I know it's not perfect.

----------


## Merri

*Update!* See post #137 for the fastest version.


This code is untested, but uses a byte array instead to build the string and it should give a good idea on how to get a better performance. This method reduces the amount of memory required so it should be noticeably faster. The speed difference should be noticeable in a compiled application, especially if you hit Advanced optimizations with array boundary check removal.



```
    Dim qx() As Byte, hx(0 To 15) As Byte
    
    ' characters 0123456789
    For i = 0 To 9: hx(i) = &H30 + i: Next
    ' characters abcdef
    For i = 0 To 5: hx(i + 10) = &H61 + i: Next
    
    ' prepare buffer (in Unicode, two bytes per character)
    ReDim qx((nBytes + (nBytes \ 40) - ((nBytes Mod 40) = 0)) * 4 + 9)
    
    j = 0
    qx(0) = 13
    qx(2) = 10
    For i = 1 To nBytes
      j = j + 4
      qx(j) = hx((ByteArr(i) And &HF0) \ &H10)
      qx(j + 2) = hx(ByteArr(i) And &HF)
      If (i Mod 40) = 0 Then
         j = j + 4
         qx(j) = 13
         qx(j + 2) = 10
      End If
    Next i

    If (nBytes Mod 40) = 0 Then j = j + 4: qx(j) = 13: qx(j + 2) = 10
    
    qx(j + 4) = &H20
    qx(j + 6) = &H7D
    qx(j + 8) = &H20
    
    'string we will be inserting
    retStr = headerStr & CStr(qx)
    PictureToRTF = retStr
    
    'remove temp metafile
    Kill sTempFile
```

I just hope I got the math right, being untested I can't tell  :Smilie:  Unless I bother to go ahead and get the all the code together...

----------


## silkworm

Hello *Merri*,

Wow, that was a fast answer, thank you!  :Wink: 

Your code is more than three times faster than mine... in an 100-loop, my code executed in 33 seconds, while yours only in 10 seconds. And that was not in the stand-alone (compiled .EXE) application... perhaps the EXE it will be even faster.

I still have one question though... why do qx array has to be in Unicode (with tho bytes/character), when only one char/byte should be enough?

... And another question... you presented another code on post #125 in which you approached the same problem differently... which one should be faster, this one, or the one in post #125?

----------


## Merri

This new one: less huge string concatenations. I had even totally forgotten about writing that one, even if it is on the same page  :Big Grin: 

qx array has to be Unicode because otherwise you'd have to use StrConv (which would do ANSI -> Unicode conversion, which is slow) and because internally VB6 strings always are Unicode. It is always much faster to do a single buffer allocation, or a single string allocation. The only problem with the byte array approach is that at some point you must make a string out of it. And that gives the only bottleneck for this code.

You could optimize it even further with some more advanced techniques... for example, allocate a string that only reserves the memory and does not touch the data (the string would contain "garbage"). When you allocate a byte array for example, or use a function such as Space$, you always also touch all the bytes in the allocated data area. A second optimization would be to use a Integer array that is "hacked" to use the very same bytes that are contained in the allocated string. Finally you'd end the integer array hack and simply use the resulting string. Oh, and of course you'd allocate the big buffer only once (ie. include the header at the beginning of the big buffer instead of concatenation afterwards). I'd expect this to roughly double the speed.

----------


## silkworm

*Merri*, I also tested your code from post #125, just for fun.
It's much slower than the last one, but still faster than mine. In an 100-loop, it ran in almost 29 seconds.

Perhaps one of the things that is causing the slowing down is that at the beginning of each loop, I had to redim the ByteAttr array to the initial value and to restore its contents from a " save array", because as your code runs, both the upper boundary of ByteAttr and the array contents are changing, so right after "For loop_test = 1 to 100" I added:

ReDim ByteArr(0 To nBytes)
ByteArr = SavedByteArr
which probably takes a little run time.

I have to admit I'm glad that the second code is fastest, because it has the roots on my code, and thus based on my idea  :Big Grin:  . Ok, ok, at least, it has my original variables name in it  :Stick Out Tongue:  (except for ByteArr, which is *moeur*'s).

I was kidding, I won't take credit for anything that's not mine. However, I'm glad that, even if I don't have advanced VB6 knowledges, I still managed to get a fast code. And I'm glad that I decided to post the results, because you helped me to have an even faster code.

Speaking of advanced techniques and getting a faster code, I know there are ways to avoid duplicate things in memory, and to declare that a string is located at another variable's address.

I found this trick in the past, when I was looking for an elegant way of swapping variables (like the good old "Swap" function back in early days of GWBasic), so instead of:



```
Sub Swap(a, b)
   Dim c
   c = a: a = b: b = c
End Sub
```

we could make *var a* think it's located at *var b*'s location in memory, and the same for b.

Unfortunately, since It was an old project (which is now abandoned somewhere on my backups), I can't find how I could do that anymore.

If you can point me in the right direction, please do so - it will be good for future projects, and not necessarily for making this code faster, because it is already fast enough for my needs... and for most other people's needs - if I did the math right, it can transform to string an image of 1.8 - 2MB/second on a computer with the configuration mentioned by me in the first post - of course, I did it in an 100-loop, but for an image of that size, I think the code should be modified to dump the string occasionaly to a file, because eventually we will get the "out of string space" error (I heard that the total string space ov VB6 is somewhere around 2 GB, but an application could have several huge strings, and we have to keep in mind that for each 40 bytes of our image, the string has 82 bytes).

----------


## Merri

*Post updated!*
Code in post #125 runs slower because it has a small bug: the header string is not separated by space from the image data. After adding a space character the image appears and you'll see it is much faster.

This is my final contribution regarding this function: a massively optimized version. I've removed any API calls that had no real effect or which could be replaced with some simple math. The safe array trick that was in the earlier version of this post has been simplified as well and I now use a Long array for all data processing. Also, a very important change is that I've removed file creation on the disk and the metafile is in memory only! So this should be "the" function for adding images to a RTB. The only change that I can think of is to switch to enhanced metafile format instead of using the very old 16-bit Windows metafile format.



```
'returns the RTF string representation of our picture
Public Function PictureToRTF(pic As StdPicture) As String
' faster version by Merri 2010-08-10
    Static hx(0 To 255) As Long
    Dim A() As Long, AH(0 To 5) As Long, AP As Long, j As Long
    Dim Meta() As Byte, MetaSize As Long
    Dim lngMetaDC As Long, lngMetaFile As Long, lngOld As Long, lngPicDC As Long, lngScreenDC As Long
    Dim strHeader As String, strFooter As String
    Dim lngHeight As Long, lngWidth As Long
    Dim udtSZ As Size
    ' calculate byte to hex characters converter only once
    If m_Hex(0) = 0 Then
        ' lower case hex notation... characters 0123456789
        For j = 0 To 9: hx(j) = &H30 + j: hx(j * 16) = hx(j): Next
        ' lower case hex notation... characters abcdef
        For j = 0 To 5: hx(j + 10) = &H61 + j: hx((j + 10) * 16) = hx(j + 10): Next
        ' m_Hex is local to the module
        For j = 0 To 255
            ' lower 16 bits contain the hex character for higher 4 bits, higher 16 bits contain the lower 4 bits
            m_Hex(j) = (hx(j And &HF&) * &H10000) Or (hx(j And &HF0&))
        Next j
    End If
    ' start our safe array hacks... create a Long safe array header
    AH(0) = 1: AH(1) = 4: AH(4) = &H3FFFFFFF
    ' a Long array is useful because you can avoid making any further PutMem4/GetMem4 calls, thus improving performance
    AP = ArrPtr(A): PutMem4 AP, VarPtr(AH(0))
    ' make a metafile in memory
    lngMetaDC = CreateMetaFile(vbNullString)
    ' himetric to twips to pixels, always round up (by using a negative value for Int)
    lngWidth = -Int(-pic.Width / 1.76388888888889 / Screen.TwipsPerPixelX)
    lngHeight = -Int(-pic.Height / 1.76388888888889 / Screen.TwipsPerPixelY)
    ' create header
    strHeader = "{\pict\wmetafile8\picw" & pic.Width & "\pich" & pic.Height & _
        "\picwgoal" & (lngWidth * Screen.TwipsPerPixelX) & "\pichgoal" & (lngHeight * Screen.TwipsPerPixelY) & " "
    ' create footer
    strFooter = "}"
    ' create a screen compatible DC
    lngScreenDC = GetDC(0)
    lngPicDC = CreateCompatibleDC(lngScreenDC)
    ReleaseDC 0, lngScreenDC
    ' set picture to the new DC
    lngOld = SelectObject(lngPicDC, pic.Handle)
    ' set size of metafile window
    SetMapMode lngMetaDC, MM_ANISOTROPIC
    SetWindowExtEx lngMetaDC, lngWidth, lngHeight, udtSZ
    ' copy bitmap to metafile
    BitBlt lngMetaDC, 0, 0, lngWidth, lngHeight, lngPicDC, 0, 0, vbSrcCopy
    'cleanup: restore original bitmap and delete (note: DeleteDC destroys lngOld as well)
    SelectObject lngPicDC, lngOld
    DeleteDC lngPicDC
    ' create file from DC
    lngMetaFile = CloseMetaFile(lngMetaDC)
    ' get size of the buffer
    MetaSize = GetMetaFileBitsEx(lngMetaFile, 0, ByVal 0&)
    ' create a buffer... and rip out the extra six bytes of a BSTR and fix pointer too
    j = SysAllocStringByteLen(0, MetaSize - 6) - 4
    ' now get the file bytes to buffer
    GetMetaFileBitsEx lngMetaFile, MetaSize, ByVal j
    ' delete the file from memory
    DeleteMetaFile lngMetaFile
    ' initialize a byte array with no data
    Meta = vbNullString
    ' get pointer to safe array header (Debug.Assert is required for VB6 IDE, there is a bug in "Not array_variable")
    AH(3) = Not Not Meta: Debug.Assert App.hInstance
    ' point to the string we created!
    A(3) = j: A(4) = MetaSize
    ' allocate final output buffer and place it to output string
    AH(3) = VarPtr(PictureToRTF)
    A(0) = SysAllocStringLen(0, Len(strHeader) + Len(strFooter) + MetaSize * 2)
    ' copy header to start of buffer
    Mid$(PictureToRTF, 1, Len(strHeader)) = strHeader
    ' copy footer to end of buffer
    Mid$(PictureToRTF, Len(PictureToRTF) - Len(strFooter) + 1, Len(strFooter)) = strFooter
    ' move array pointer to position
    AH(3) = StrPtr(PictureToRTF) + LenB(strHeader)
    ' convert metafile bytes to hex & place to output buffer
    For j = 0 To MetaSize - 1
        ' convert 8-bit byte to a Long that contains lowercase hexadecimal character representation of higher and lower 4 bits
        A(j) = m_Hex(Meta(j))
    Next j
    ' end safe array hack
    AH(3) = AP: A(0) = 0
End Function
```

Full benchmark project with updated modRTFpic.bas included. The results below are from a compiled program. The benchmark program has been updated so that the true speed of the function is timed. It happens to be so that adding the image to the RichTextBox now takes much longer than generating the RTF data for it...  :Smilie:

----------


## Merri

I updated the last post to reduce amount of "worthless" code. There was no discussion on post #137 so I went ahead and made a final update into it which is about as ultimate version as it can get. The RTF image data generation is super fast now, all the performance bottlenecks have been killed off.

Shouldn't be an issue anymore to keep adding images to your RTB. The only limitation is that adding a huge image will degrade performance of RTB itself, for example, shutting down your application will take a long time as RTB does it's cleanup. You'll notice this if you test some 1920 x 1080 pixels or bigger image.


The modRTFpic.bas is compatible with the old one, so you can just replace the old file with the new one. It includes all the various versions of PictureToRTF posted in this thread, it is easy to remove them  :Smilie:  I have also rewritten InsertPicture function.

----------


## silkworm

Wow Merri, that's a nice piece of code! Very good work, congratulations!

It would have been nice if this code was here five years ago, so many people could use it.

I personally thank you, since I can still take advantages of it.

----------


## WhatIf

[QUOTE=moeur;2131031]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.


Hello,

Please have patience with me. I am getting on in years, have a reasonable to good understanding of VB6 and would like some help on the manipulation of data within RTB coding - having never done it before.

I have used the downloaded code to create a table having six columns and four rows. I have inserted data into the rows and columns.

I have made the RTB dimension the same as an 'A' size sheet of paper.

It is my aim to create six similar (identical format, different data) but separate tables on the same 'A' size RTB.

I think I can manage this but I cannot seem to get each table displaying in different colours. I have done two tables at the moment - but each are the same colour.

Would some kind soul put me out of my misery and point me in the right direction on how to make each table a different colour?

Regards to all who participate in this fantastic forum.

----------


## Vbstr

the gif animator example, both the original and the ocx form both seem to crash the app if you have to many gifs, try copy pasting his :wink: text maybe 40 times then hinting the button. It freezes then crashes  :Frown:  the problem seems to be in the advanceframe sub, any ideas how to fix?

----------


## Merri

You can try the improved PictureToRTF in post #137 which for the least reduces unnecessary processing a good degree. It won't of course fix any possible memory leak in the GIF processing code that there may be. However it could be possible for you to have a look at LaVolpe's solutions for GIFs, figure out how to make a StdPicture of each frame and then simply swap between these frames. This would probably give you more reliable code as well as faster end results, but more work for you to do. It isn't very likely someone fixes moeur's code.

----------


## Vbstr

thanks for the response,i'll try it out. I think ultimately, even with bug fixes the best route to do this is the approach virtual listviews do for extremely large data, in that you don't load all at once, you only load and show the data the user is currently looking at within the size of the window. Maybe i'll find a way to where only the smilies shown within the visible part of the richedit are animated and the rest not, until you scroll to a point where they're visible.

----------


## Merri

In this case it seems there is a memory leak, so you'll eventually have a crash anyway; in the other hand I guess RichEdit isn't designed for animated GIFs, but I'm not an expert in the area so I can't be sure – there may be another way of doing it that won't require constant replace of RTF data.

It should be possible to locate the visible area so only the ones that are visible are replaced, however this will be quite complex I'm afraid – also, RichEdit is probably already optimized so that it won't do anything for out-of-visible-area data. Hard text replace may be troublesome for it.

Anyway, good luck for whichever route you try!

----------


## LaVolpe

> In this case it seems there is a memory leak, so you'll eventually have a crash anyway...


Yep. Taking a quick look at the clsGIFanimator only, below items are leaks.
If someone does want to tweak the original, they should read & apply my 'Memory Leak FAQ' linked in my signature below.


```
Routine: EraseBackGround
Line: hbrBkgnd = CreateSolidBrush(fillColor)
Problem: brush needs to be destroyed & is not

Routine: LoadGIF
Line: SelectObject arrayFrameData(i).hDc, objPIC.Picture.Handle
Problem: Return value should be reselected into DC when done with objPic.Picture.Handle

Routine: LoadGIF
Line: ReDim Preserve arrayFrameData(0 To i)
Problem: If array is resized, hDCs are leaked because they are not destroyed

Routine: Class_Terminate
Line: DeleteDC arrayFrameData(i).hDc
Problem: The SelectObject problem above causes leaks here
```

Also noted. I'm not slamming that gif animation control, but the GIF processing is very resource heavy. Every frame has a DC created. If the gif had 10 frames and the GIF was pasted some 40 times: that equates to 400 DCs created, 400 stdPictures created & if transparency exists, another 400 stdPictures used as masks. I didn't analyze the code very well, maybe I might be over-exaggerating, but don't think so.

If the system ran out of resources for more GDI objects, the object creations would fail, but no code is testing against that. And to have the code continue on ignoring failures can result in yet more leaks. All the above would have to be fixed if it were to be used. 

Even the best GIF animator I ever wrote, requires 1 DC per control + up to 3 bitmaps (1 bit, 8 bit, & 24 bit) per GIF but no less than 1 (8 bit). Those numbers are per GIF, not per GIF frame.

Edited: I see he posted 2 versions of his control
This is a quick look of the clsGIF class from the 'most recent version' of his control (viewed via WordPad)


```
Routine: AddFrame
Line: SelectObject localDC, .Picture.hPAL
Problem: Anything selected into a DC should be selected out else leaks can occur

Routine: AddFrame
Line: localDC = CreateCompatibleDC(GetDC(0))
Problem: Calling GetDC without a subsequent ReleaseDC can cause leaks

Routine: SetDC
Line: hBitmap = CreateCompatibleBitmap(GetDC(0), mvarxWidth, mvaryHeight)
Line: .hdc = CreateCompatibleDC(GetDC(0))
Problem: Calling GetDC without a subsequent ReleaseDC can cause leaks

Routine: hdcToPicture
Line: hPAL = CreatePalette(LogPal)
Problem: Palette is not destroyed

Routine: Class_Terminate
Line: Set mvarFrames = Nothing
Problem: The collection of the clsFrame.cls which has a DC assigned. Not destroyed in this event or that class' Terminate event

Routine: CopyFrame
Line: BkgndDC = CreateCompatibleDC(hdc)
Problem: The created DC is not destroyed

Routine: CopyFrame
Line: BkgndBM = CreateCompatibleBitmap(hdc, mvarxWidth, mvaryHeight)
Problem: The created bitmap is not destroyed

Routine: CopyFrame
Line: SelectObject BkgndDC, BkgndBM
Problem: Not unselecting stuff you select into a DC can cause leaks
```

*Edited one more time*:One doesn't even need the gif control. Granted it negates users from parsing the GIF, but a gif parser can be added to class structure which also negates a custom ocx dependency. Since the RTF will accept multiple formats, the current GIF (smiley) could be updated by being converted to bitmap (not recommended by RTF sources), png, metafile or jpeg. PNG might be a suitable substitute if RTF supports transparent PNGs? Maybe a holiday weekend proof of concept project upcoming? Hmmmm....

----------


## LaVolpe

> ...The only change that I can think of is to switch to enhanced metafile format instead of using the very old 16-bit Windows metafile format.


Merri, don't think that'll work. I can format a jpg, png, emf using the correct xxxblip tags & apply it to a VB RFTbox, but it simply won't use it. The same string pasted inside a RTF file & opened with WordPad, also won't use it. But open it with Word & all is good. The RTFbox doesn't support many of the image tags.

For all: Here's a GDI+ solution to inserting an image into the RTF. Just another option.

Below CLASS is provided with these notes
1) GDI+ cannot load all image types well. For more info see GDI+ Classes & Alpha Image Control links in my signature below
2) Supports PNG & TIFF. No animation support
3) There is no proportional scaling, but you can add that easily enough in the pvImagetoWMFStream routine
4) There are only 2 public functions in the class
- GetRTFpictureFormat_ImageFile for loading image from file (unicode supported)
- GetRTFpictureFormat_ImageArray for loading image from an array (must be 1D array)

Sample call: RichTextBox1.SelRTF = theClass.GetRTFpictureFormat_ImageFile("C:\Test.Png", 32, 32)


```
Option Explicit

Private Type GdiplusStartupInput
    GdiplusVersion           As Long
    DebugEventCallback       As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs   As Long
End Type
Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)

Private Type RECTF
    nLeft As Single
    nTop As Single
    nWidth As Single
    nHeight As Single
End Type
Private Declare Function GdipRecordMetafile Lib "gdiplus" (ByVal referenceHdc As Long, ByVal pType As Long, ByRef frameRect As RECTF, ByVal frameUnit As Long, ByVal description As Long, ByRef metafile As Long) As Long
Private Declare Function GdipEmfToWmfBits Lib "gdiplus" (ByVal hemf As Long, ByVal cbData16 As Long, ByVal pData16 As Long, ByVal iMapMode As Long, ByVal eFlags As Long) As Long
Private Declare Function GdipGetHemfFromMetafile Lib "gdiplus" (ByVal metafile As Long, ByRef hemf As Long) As Long
Private Declare Function GdipLoadImageFromStream Lib "gdiplus" (ByVal Stream As Long, Image As Long) As Long
Private Declare Function GdipGetImageBounds Lib "gdiplus.dll" (ByVal nImage As Long, srcRect As RECTF, srcUnit As Long) As Long
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus.dll" (ByVal pImage As Long, ByRef graphics As Long) As Long
Private Declare Function GdipDrawImageRectRect Lib "gdiplus" (ByVal hGraphics As Long, ByVal hImage As Long, ByVal dstX As Single, ByVal dstY As Single, ByVal dstWidth As Single, ByVal dstHeight As Single, ByVal srcX As Single, ByVal srcY As Single, ByVal srcWidth As Single, ByVal srcHeight As Single, ByVal srcUnit As Long, ByVal imageAttributes As Long, ByVal Callback As Long, ByVal callbackData As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus.dll" (ByVal mGraphics As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal FileName As Long, hImage As Long) As Long

Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32.dll" (ByVal hemf As Long) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private m_Token As Long

Private Sub Class_Initialize()
    Dim GSI As GdiplusStartupInput
    Dim pa As Long, hMod As Long
    
    On Error Resume Next
    GSI.GdiplusVersion = 1&
    Call GdiplusStartup(m_Token, GSI)
End Sub

Private Sub Class_Terminate()
    If m_Token Then GdiplusShutdown m_Token
End Sub

Public Function GetRTFpictureFormat_ImageArray(ImageData() As Byte, ByVal destWidth As Long, ByVal destHeight As Long) As String

    ' passing 0 for width,height will have image rendered at original width,height

    Dim outData() As Byte, IStream As IUnknown, hImage As Long
    If m_Token = 0 Then Exit Function
    If Not Not ImageData() Then
        Set IStream = pvIStreamFromArray(VarPtr(ImageData(LBound(ImageData))), (UBound(ImageData) - LBound(ImageData) - 1&))
        If Not IStream Is Nothing Then 
            If GdipLoadImageFromStream(ObjPtr(IStream), hImage) = 0& Then
                If pvImagetoWMFStream(hImage, outData(), destWidth, destHeight) = True Then
                    GetRTFpictureFormat_ImageArray = pvStreamToRTFwmf(outData(), destWidth, destHeight)
                End If
            End If
        End If
    End If
    Debug.Assert App.hInstance

End Function

Public Function GetRTFpictureFormat_ImageFile(ByVal FileName As String, ByVal destWidth As Long, ByVal destHeight As Long) As String

    ' passing 0 for width,height will have image rendered at original width,height
    
    Dim hImage As Long, outData() As Byte
    If m_Token = 0 Then Exit Function
    If GdipLoadImageFromFile(StrPtr(FileName), hImage) Then Exit Function
    If pvImagetoWMFStream(hImage, outData(), destWidth, destHeight) = True Then
        GetRTFpictureFormat_ImageFile = pvStreamToRTFwmf(outData(), destWidth, destHeight)
    End If

End Function

Private Function pvImagetoWMFStream(hImage As Long, outArray() As Byte, Width As Long, Height As Long) As Boolean

    Dim lSize As Long, hDC As Long
    Dim hGraphics As Long, hMetaFile As Long
    Dim sizeF As RECTF
    Const UnitPixel As Long = 2&
    Const MetafileTypeEmf As Long = 3&
    Const MM_ANISOTROPIC As Long = 8&
    
    GdipGetImageBounds hImage, sizeF, UnitPixel
    hDC = GetDC(GetDesktopWindow)
    If GdipRecordMetafile(hDC, MetafileTypeEmf, sizeF, UnitPixel, 0&, hMetaFile) = 0& Then
        If GdipGetImageGraphicsContext(hMetaFile, hGraphics) = 0 Then
            GdipDrawImageRectRect hGraphics, hImage, 0!, 0!, sizeF.nWidth, sizeF.nHeight, sizeF.nLeft, sizeF.nTop, sizeF.nWidth, sizeF.nHeight, UnitPixel, 0&, 0&, 0&
            GdipDeleteGraphics hGraphics
        Else
            GdipDisposeImage hMetaFile: hMetaFile = 0&
        End If
    End If
    ReleaseDC GetDesktopWindow(), hDC
    GdipDisposeImage hImage
    
    If hMetaFile Then
        If GdipGetHemfFromMetafile(hMetaFile, hImage) = 0& Then
            lSize = GdipEmfToWmfBits(hImage, 0&, 0&, MM_ANISOTROPIC, 0&)
            If lSize Then
                ReDim outArray(0 To lSize - 1&)

                ' modify width/height if proportional scaling desired. Use ratios btwn passed sizes & sizeF sizes

                If Width < 1& Then Width = sizeF.nWidth
                If Height < 1& Then Height = sizeF.nHeight
                pvImagetoWMFStream = (GdipEmfToWmfBits(hImage, lSize, VarPtr(outArray(0)), MM_ANISOTROPIC, 0&) <> 0&)
            End If
            DeleteEnhMetaFile hImage
        End If
        GdipDisposeImage hMetaFile
    End If

End Function

Private Function pvStreamToRTFwmf(inStream() As Byte, Width As Long, Height As Long) As String

    Dim Header As String
    Dim L As Long, c As Long, x As Long
    Dim lSize As Long, sLUT(0 To 255) As String * 2
    Const LineLen As Long = 256&
    
    Header = "{\pict\wmetafile8" & _
            "\picwgoal" & CStr(Width * Screen.TwipsPerPixelX) & _
            "\pichgoal" & CStr(Height * Screen.TwipsPerPixelY) & _
            " "
    
    lSize = UBound(inStream) - LBound(inStream) + 1
    pvStreamToRTFwmf = Space$(Len(Header) + 2 * (lSize \ LineLen + lSize) + 1)
    
    For x = 0& To 15&: sLUT(x) = "0" & LCase$(Hex(x)): Next '
    For x = 16& To 255&: sLUT(x) = LCase$(Hex(x)): Next
    
    c = Len(Header)
    Mid$(pvStreamToRTFwmf, 1, c) = Header
    
    c = c + 1&: x = LBound(inStream)
    For L = 1& To lSize \ LineLen
        For x = x To x + LineLen - 1&
            Mid$(pvStreamToRTFwmf, c, 2) = sLUT(inStream(x))
            c = c + 2&
        Next
        Mid$(pvStreamToRTFwmf, c, 2) = vbCrLf
        c = c + 2&
    Next
    For x = x To UBound(inStream)
        Mid$(pvStreamToRTFwmf, c, 2) = sLUT(inStream(x))
        c = c + 2&
    Next
    Mid$(pvStreamToRTFwmf, c, 1) = "}"

End Function

Private Function pvIStreamFromArray(ArrayPtr As Long, Length As Long) As stdole.IUnknown
    
    ' Purpose: Create an IStream-compatible IUnknown interface containing the
    ' passed byte aray. This IUnknown interface can be passed to GDI+ functions
    ' that expect an IStream interface -- neat hack
    
    On Error GoTo HandleError
    Dim o_hMem As Long
    Dim o_lpMem  As Long
     
    If ArrayPtr = 0& Then
        CreateStreamOnHGlobal 0&, 1&, pvIStreamFromArray
    ElseIf Length <> 0& Then
        o_hMem = GlobalAlloc(&H2&, Length)
        If o_hMem <> 0 Then
            o_lpMem = GlobalLock(o_hMem)
            If o_lpMem <> 0 Then
                CopyMemory ByVal o_lpMem, ByVal ArrayPtr, Length
                Call GlobalUnlock(o_hMem)
                Call CreateStreamOnHGlobal(o_hMem, 1&, pvIStreamFromArray)
            End If
        End If
    End If
    
HandleError:
End Function
```

----------


## richosr

Hi,

when I add your clsSubClass.cls to a project, if I click the Stop button in VB 6 VB6 closes with an error message, 'error in unkown module', any ideas?

regards

Steve






_"If all you own is a hammer, every problem starts looking like a nail"_

----------


## LaVolpe

When subclassing an uncompiled project, NEVER press the stop button, never execute an End statement.

----------


## richosr

Hi,

First of all thanks for some great tips and code.

I am using your URL detection, but now I do not seem to be able to get the selchange to function. Is this something to do with the sendmessage, and any ideas on how to fix please?

kindest regards

Steve

----------


## richosr

> Hi,
> 
> First of all thanks for some great tips and code.
> 
> I am using your URL detection, but now I do not seem to be able to get the selchange to function. Is this something to do with the sendmessage, and any ideas on how to fix please?
> 
> kindest regards
> 
> Steve


I think I may have fixed it: 

I added a call to the selchange event in the wmarrival sub class of the form:



```
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
        rtfTextBox_SelChange

    Select Case uMsg
    Case WM_NOTIFY
```

and the selchange event detection now works and the URL detection still works too.

However if the call to the selchange event is put anywhere else in the wmarrival sub, when you close the form with the X a new form always opens.

The only issue is that the left alignment now will not operate on any text that has aleady been centered or right aligned, but thats another issue!

Steve

----------


## jmsrickland

mouer,

I downloaded your project from post #62, RTBGIF.zip. I have a couple of concerns with it I hope you might be able to put me on the right path.

Instead of loading all of the gif images from storage I would like to be able to load them from Picturebox controls. I have 22 picturebox controls pre-loaded with the smilies. I want to be able to load the images from the picturebox controls in the FormLoad event into the image collection instead of reading them in from the disk.

My other issue is that it appears I cannot do a ReplaceTag more than one time. When I double-click on a smiley (double click on the picturebox that has the smiley) that I want to put in the RTB the first one goes in OK. However, when I click on it again or even another smiley something wierd happens.

I use the following to put a smiley on the RTB



```
Private Sub picSmilie_Click(Index As Integer)

 RTB.Text = RTB.Text & picSmilie(Index).Tag '<-- Tag = :wave: for this particular smiley
 GIF.replaceTags RTB
   
End Sub
```

The first time I click on the smiley picturebox it goes on the RTB OK like this: (note <smiley> is the actual picture)

This is some text <smiley> 

Then I type more text and when I click on another picturebox I get this:

This is some text 01  this is some more text <smiley>

The first smiley goes away and is replaced with 01.

----------


## RobDog888

Looking for a way to use linked text with anchors within the RTB to have it scroll to the anchor instead of opening a browser.

Looking into the .UpTo and .Find methods as possibilities. Any tips?

----------


## dilettante

RichEdit 3.0 has hidden text, which might be used as a Find target.

----------


## RobDog888

thinking I can use another link with an # tag and a keyword to use to locate the target.
Just need to test if the .Find method will see the target hyperlink content or not. I kina doubt it but still looking

----------


## dilettante

Without knowing what you are building this may be useful or useless, but...

At a certain point isn't it just easier to use the DHTMLEdit control and HTML instead of RichTextBox and RTF format?  In Browse mode it gives you more control over things than using a WebBrowser control, plus it offers Edit mode allowing it to be used for user input/editing as well. You can even optionally enable script inside the documents.

Just a thought.

----------


## RobDog888

Thanks for the suggestion but we had been using a web browser control and now we need dynamically changing text  with the current xml scripting setup its not possible*




* Easily possible if we had enough time lol.

----------


## jmsrickland

> Since there is no .SelHighlight property of the RichTextBox control, I created one.
> 
> ```
> 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
> ...


I don't see how this works. I ran the code, doesn't change anything. Am I supposed to do something else other than running code as is?

----------


## CreativeDreamer

I was wondering ..... How could you do vertical a vertical textbox on a Rich Text box? (similar to MS Word)

----------


## dlinda2010

I was wondering if you are still using VB6?  I tried to convert your class to .net and I get no table lines except between the columns

----------

