Dynamically sizing a RichTextBox control 5

[musik]

I have the need to resize a RichTextBox control based on its contents. Because it's rich text, the contents can be stored in many different fonts, point sizes, styles, etc. Does anyone know of a way to calculate/query/get/find/etc. the size (esp. vertical) of the text being displayed in a RichTextBox?

Thanks!
-musik

 

[Ambles]

I think a know a bit of a long winded way of doing this. You can set the font of a INVISIBLE picture box to that of the rich text control, and then call the TextWidth and TextHeight methods of the picture box passing the text of the rich text control.

Or you could add in the GetTextExtentPoint32 Windows API. That will give you the size of text in a certain font. But make sure you call the SelectObject with you font first, else it will just give you the size of a default font.

Personally i would do the first one.

Hope this helps

 

[strongm]

As musik points out, these solution won't work for an RTF because a single word, let alone a single line, can be a mixture of all different size fonts.

I do have a vague idea for a solution...I'll have to mull it over.

 

[musik]

I could use GetTextExtentPoint32, but I would have to parse the RTF to find every piece that's a different font/style/point size. ugh.

What was your vague idea, strongm?

 

[strongm]

Hah! Over a month since I said that...

And it is no longer just a vague idea. I have it running in a live application. I'll need to dig out the code...

 

[musik]

I would really appreciate it, strongm!

 

[strongm]

Just trying to figure out how to extract the core functionality from the code (live version actually figures out how many lines in whatever format in a RichText box will print to an A4 page)...

 

[strongm]

OK, here it comes...

[tt]
Option Explicit

Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Type CharRange
cpMin As Long ' First character of range (0 for start of doc)
cpMax As Long ' Last character of range (-1 for end of doc)
End Type

Private Type FormatRange
hdc As Long ' Actual DC to draw on
hdcTarget As Long ' Target DC for determining text formatting
rc As Rect ' Region of the DC to draw to (in twips)
rcPage As Rect ' Region of the entire DC (page size) (in twips)
chrg As CharRange ' Range of text to draw (see above declaration)
End Type


Private Const WM_USER As Long = &H400
Private Const EM_FORMATRANGE As Long = WM_USER + 57

Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function SetRect Lib "USER32" (lpRect As Rect, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, lp As Any) As Long


Private Sub Command1_Click()
RichTextBox1.Height = RTFHeight(RichTextBox1) ' + relevant border widths, if box has borders
End Sub

' Measure RTF height in a Richtextbox of a given width
' Change the width of the text box, and the result will change
' Note that returned value is the height of the text, and excludes
' any borders of the Richtextbox control
' Returns: height of text in twips
Public Function RTFHeight(RTF As RichTextBox) as long
Dim fr As FormatRange
Dim r As Long
Dim myrect As Rect

SetRect myrect, 0, 0, RTF.Width, 655360 ' Allows for a height of 43690 pixels

fr.hdc = GetDC(RTF.hWnd) ' Use the same DC for measuring and pretend rendering
fr.hdcTarget = GetDC(RTF.hWnd)
fr.rc = myrect ' Indicate the area on page to draw to
fr.rcPage = myrect ' Indicate entire size of page
fr.chrg.cpMin = 0 ' Indicate start of text through
fr.chrg.cpMax = -1 ' end of the text

SendMessage RTF.hWnd, EM_FORMATRANGE, False, fr

' Allow the RTF to free up memory
r = SendMessage(RTF.hWnd, EM_FORMATRANGE, False, ByVal CLng(0))
RTFHeight = fr.rc.Bottom
End Function

 

[strongm]

Did this help?

 

[musik]

Sorry... I'm in the throes of term-start preps (I teach and Direct IT at a local college) and haven't had a chance to put this into practice. It'll likely be the week of the 20th before things calm down enough for me to get to it. But it's in the back of my mind!

Thanks for posting this!

 

[strongm]

Any joy? Or still snowed under?

 

[rdavis]

strongm,

I was looking for something like this for the longest time, but I did not think I would find it here. I'll let you know if it works for me. Thanks.

Rob

 

[musik]

Still snowed under, but it's slowly letting up. I thought it would end once the "break" (hahaha!) was over and students were back. WRONG. I will get to it eventually.