RichTextBox Tricks and Tips

[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

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 Unless I bother to go ahead and get the all the code together...

[silkworm]

Hello Merri,

Wow, that was a fast answer, thank you!

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

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 . Ok, ok, at least, it has my original variables name in it (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...

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