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?
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.
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.
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.
Last edited by Merri; Aug 11th, 2010 at 09:36 AM.
Reason: Header is fixed now, so this code actually works
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.
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.
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
(... 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:
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:
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.
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.
Code:
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...
Last edited by Merri; Aug 11th, 2010 at 09:37 AM.
Reason: Swapped bytes, it works now.
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?
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.
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:
Code:
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).
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.
Code:
'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...
Last edited by Merri; Aug 10th, 2010 at 10:55 AM.
Reason: The attached zip contained an exe by mistake: removed it
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.
[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.
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?
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.
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.
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.
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.
Code:
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)
Code:
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....
Last edited by LaVolpe; Dec 22nd, 2010 at 11:00 AM.
Insomnia is just a byproduct of, "It can't be done"
...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)
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
Last edited by LaVolpe; Dec 23rd, 2010 at 09:59 AM.
Reason: cut back a bit of the class
Insomnia is just a byproduct of, "It can't be done"
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"
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
"If all you own is a hammer, every problem starts looking like a nail"
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:
Code:
Private Sub FormSubClass_WMArrival(hwnd As Long, uMsg As Long, wParam As Long, lParam As Long, lRetVal As Long)
Dim notifyCode As NMHDR
Dim LinkData As ENLINK
Dim URL As String
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
"If all you own is a hammer, every problem starts looking like a nail"
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
Code:
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.
Anything I post is an example only and is not intended to be the only solution, the total solution nor the final solution to your request nor do I claim that it is. If you find it useful then it is entirely up to you to make whatever changes necessary you feel are adequate for your purposes.
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
VB/Office Guru™ (AKA: Gangsta Yoda™ ®)
I dont answer coding questions via PM. Please post a thread in the appropriate forum.
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.
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.
VB/Office Guru™ (AKA: Gangsta Yoda™ ®)
I dont answer coding questions via PM. Please post a thread in the appropriate forum.
Since there is no .SelHighlight property of the RichTextBox control, I created one.
Code:
Public Sub HighLight(RTB As RichTextBox, lColor As Long)
'add new color to color table
'add tags \highlight# and \highlight0
'where # is new color number
Dim iPos As Long
Dim strRTF As String
Dim bkColor As Integer
With RTB
iPos = .SelStart
'bracket selection
.SelText = Chr(&H9D) & .SelText & Chr(&H81)
strRTF = RTB.TextRTF
'add new color
bkColor = AddColorToTable(strRTF, lColor)
'add highlighting
strRTF = Replace(strRTF, "\'9d", "\up1\highlight" & CStr(bkColor) & "")
strRTF = Replace(strRTF, "\'81", "\highlight0\up0 ")
.TextRTF = strRTF
.SelStart = iPos
End With
End Sub
Notice that in addition to inserting the \highlight tags I also insert \up# tags.
This is so that I can check to see if a selection is highlighted by querying the
.SelCharOffset function. This routine relies on the following function that adds
a new color to the RTF color table
Code:
Function AddColorToTable(strRTF As String, lColor As Long) As Integer
Dim iPos As Long, jpos As Long
Dim ctbl As String
Dim tagColors
Dim nColors As Integer
Dim tagNew As String
Dim i As Integer
Dim iLen As Integer
Dim split1 As String
Dim split2 As String
'make new color into tag
tagNew = "\red" & CStr(lColor And &HFF) & _
"\green" & CStr(Int(lColor / &H100) And &HFF) & _
"\blue" & CStr(Int(lColor / &H10000))
'find colortable
iPos = InStr(strRTF, "{\colortbl")
If iPos > 0 Then 'if table already exists
jpos = InStr(iPos, strRTF, ";}")
'color table
ctbl = Mid(strRTF, iPos + 12, jpos - iPos - 12)
'array of color tags
tagColors = Split(ctbl, ";")
nColors = UBound(tagColors) + 2
'see if our color already exists in table
For i = 0 To UBound(tagColors)
If tagColors(i) = tagNew Then
AddColorToTable = i + 1
Exit Function
End If
Next i
'{\fonttbl{\f0\fnil\fcharset0 Verdana;}}
'{\colortbl ;\red0\green0\blue0;\red128\green0\blue255;}
split1 = Left(strRTF, jpos)
split2 = Mid(strRTF, jpos + 1)
strRTF = split1 & tagNew & ";" & split2
AddColorToTable = nColors
Else
'color table doesn't exists, let's make one
iPos = InStr(strRTF, "{\fonttbl") 'beginning of font table
jpos = InStr(iPos, strRTF, ";}}") + 2 'end of font table
split1 = Left(strRTF, jpos)
split2 = Mid(strRTF, jpos + 1)
strRTF = split1 & "{\colortbl ;" & tagNew & ";}" & split2
AddColorToTable = 1
End If
End Function
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?
Anything I post is an example only and is not intended to be the only solution, the total solution nor the final solution to your request nor do I claim that it is. If you find it useful then it is entirely up to you to make whatever changes necessary you feel are adequate for your purposes.
The RichTextBox control has the ability to detect URLs as they are typed. It can convert this text into a hyperlink which can launch a browser when clicked.
To turn on Auto URL detection simply send the RTB an EM_AUTOURLDETECT message.
When the control detects that a URL is being entered, it reformats the text being entered so that it looks like a hyperlink and marks that text with a CFE_LINK effect.
When the mouse pointer is over text with a CFE_LINK effect, the RTB can be configured to send a message to its parent. In order to respond to mouse events over the hyperlink text, the parent has to be subclassed or hooked.
The following code shows how to setup Auto URL detection
Code:
Public Sub EnableAutoURLDetection(RTB As RichTextBox)
'enable auto URL detection
SendMessage RTB.hwnd, EM_AUTOURLDETECT, 1&, ByVal 0&
'subclass the parent of the RTB to receive EN_LINK notifications
Set FormSubClass = New clsSubClass
FormSubClass.Enable RTB.Parent.hwnd
'set RTB to notify parent when user has clicked hyperlink
SendMessage RTB.hwnd, EM_SETEVENTMASK, 0&, ByVal ENM_LINK
End Sub
And to respond to a left mouse click you could do the following in your form's subclass routine.
Code:
Private Sub FormSubClass_WMArrival(hwnd As Long, uMsg As Long, wParam As Long, lParam As Long, lRetVal As Long)
Dim notifyCode As nmhdr
Dim LinkData As ENLINK
Dim URL As String
Select Case uMsg
Case WM_NOTIFY
CopyMemory notifyCode, ByVal lParam, LenB(notifyCode)
If notifyCode.code = EN_LINK Then
'A RTB sends EN_LINK notifications when it receives certain mouse messages
'while the mouse pointer is over text that has the CFE_LINK effect:
'To receive EN_LINK notifications, specify the ENM_LINK flag in the mask
'sent with the EM_SETEVENTMASK message.
'If you send the EM_AUTOURLDETECT message to enable automatic URL detection,
'the RTB automatically sets the CFE_LINK effect for modified text that it
'identifies as a URL.
CopyMemory LinkData, ByVal lParam, Len(LinkData)
If LinkData.Msg = WM_LBUTTONUP Then
'user clicked on a hyperlink
'get text with CFE_LINK effect that caused message to be sent
URL = Mid(RTB.Text, LinkData.chrg.cpMin + 1, LinkData.chrg.cpMax - LinkData.chrg.cpMin)
'launch the browser here
ShellExecute 0&, "OPEN", URL, vbNullString, "C:\", SW_SHOWNORMAL
End If
End If
lRetVal = FormSubClass.callWindProc(hwnd, uMsg, wParam, lParam)
Case Else
lRetVal = FormSubClass.callWindProc(hwnd, uMsg, wParam, lParam)
End Select
End Sub
Attached is a project that demonstrates the whole idea.
I have done the same using this subroutine for years
BUT, IT autodetects a double backslash then text as a hyperlink by mistake!
I assume it is a programming bug MS missed?
And your project file also does the same thing
Is there a way to prevent it from aurtodetecting fake URL?
This one needs no class and can be turned off or on for the RTB control
put a rtxbox called rtxtTitles on a form and run it like this
'turn on autodetect
MyDetectURL rtxtTitles, True, rtxtTitles
Code:
Public Sub MyDetectURL(p_RichText As Object, p_blnDetect As Boolean, RTB As RichTextBox)
Dim lngRet As Long
Dim strText As String
Dim keepstart As Long
With p_RichText
keepstart = RTB.SelStart
' this line is needed because the function will not update the url if you had it before
strText = .TextRTF
' send message to detect urls
' notice the Abs function. This is needed to pass 0 or 1
' in VB true is -1, so we have to get the absolute value of that
' SendMessage(rtb.hWnd, EM_AUTOURLDETECT, Abs(p_blnDetect), ByVal 0)
If p_blnDetect = True Then
'turn on autodetect true = 1
SendMessage RTB.hWnd, EM_AUTOURLDETECT, 1, ByVal 0
Else
'turn off autodetect false = 0
SendMessage RTB.hWnd, EM_AUTOURLDETECT, 0, ByVal 0
End If
'rewrite the text into the RichText so it will change all URLs if you had them before
.TextRTF = strText
RTB.SelStart = keepstart
RTB.SelColor = vbBlack '???
End With
End Sub
Last edited by sdowney1; Apr 15th, 2024 at 01:55 PM.