set height to richtextbox to height of text

[hinchdog]

how can i dynamically set the height of a richtextbox to the height of the text inside?

 

[vb5prgrmr]

check out textheight and textwidth in help

 

[strongm]

Only a useful approach if the contents of the RTB are all in a single font, with a single style applied - which rather defeats the purpose of using a RTB in the first place...

 

[strongm]

So here is one potential solution. Note that this is a conversion of part of some code that I wrote to replace the RTB SelPrint method; as a result it has two outstanding issues that I haven't bothered to address when working onscreen: firstly, it only works 100% accurately as written if the RTB whose text is being measured has no borders set, and secondly if the text in the RTB all fits on one line the routine fails to get the right result. However, I leave the solution of these two issues as an exercise for the interested user.

Right, here's the code. Drop this into a module:
[tt]
Option Explicit

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Public Const SM_CXBORDER = 5
Public Const SM_CYBORDER = 6


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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wp As Long, lp As Any) As Long




' RTF - richtextbox whose text height is to be measured
' MeasureRTF - richtextbox that is used to do the measuring
' These CAN be the same but, since the routine resizes the measuring RTF
' as it goes this would produce unwanted visual effects
' Function assumes that both RTBs are hosted in a container whose ScaleMode is set to twips
Public Function RTFTextHeight(RTF As RichTextBox, MeasureRTF As RichTextBox) As Long

Dim fr As FormatRange
Dim rcDrawTo As Rect
Dim rcPage As Rect
Dim TextLength As Long
Dim NextCharPosition As Long


Dim MeasuringhDC As Long
MeasuringhDC = GetDC(RTF.hwnd)

' Get length of text in RTF
TextLength = Len(RTF.Text)

' Set target area rect
' We should probably add in offsets for any borders that have been set on the RTB
' as this could make a minor difference to the results
rcPage.Left = 0
rcPage.Top = 0
rcPage.Right = RTF.Width
rcPage.Bottom = RTF.Height

MeasureRTF.Width = RTF.Width
MeasureRTF.Height = 0

' Set up the print instructions
fr.hdc = MeasuringhDC ' Use the same DC for measuring and rendering (only we won't render)
fr.hdcTarget = MeasuringhDC
fr.rc = rcDrawTo ' Indicate the area on page to draw to
fr.rcPage = rcPage ' Indicate entire size of page
fr.chrg.cpMin = 0 ' Indicate start of text through
fr.chrg.cpMax = -1 ' end of the text

' Right, keep increasing the height of our measuring DC
' until it is big enough for all the charcaters
Do Until NextCharPosition >= TextLength

' Set up the 'print' instructions
' Essentially we are going to pretend to render all the text from
' our source RTF into another DC (in this example we are using another
' RTF, but it can be any DC you like - including a printer...) and then
' seeing if all the text fits

fr.hdc = MeasuringhDC ' Use the same DC for measuring and rendering
fr.hdcTarget = MeasuringhDC ' Point at printer hDC
fr.rc = rcDrawTo ' Indicate the area on page to draw to
fr.rcPage = rcPage ' Indicate entire size of page
fr.chrg.cpMin = 0 ' Indicate start of text through
fr.chrg.cpMax = -1 ' end of the text


' Set rect in which to print
' Again, we should probably put in offsets for any borders that have been set
rcDrawTo.Left = 0
rcDrawTo.Top = 0
rcDrawTo.Right = MeasureRTF.Width
rcDrawTo.Bottom = MeasureRTF.Height

' OK, let's measure

NextCharPosition = SendMessage(RTF.hwnd, EM_FORMATRANGE, False, fr)
DoEvents 'Make sure message gets responded to
MeasureRTF.Height = rcDrawTo.Bottom + Screen.TwipsPerPixelY 'Increase height

Loop

ReleaseDC MeasureRTF.hwnd, MeasuringhDC
RTFTextHeight = MeasureRTF.Height

End Function
[/tt]
And here's an example of it in use. You need a form with a command button and two RTBs. The second one should have its Visible property set to false:
[tt]
Option Explicit

Private Sub Command1_Click()
Dim MeasuredHeight As Long

'RichTextBox2.Height = 0
MeasuredHeight = RTFTextHeight(RichTextBox1, RichTextBox2)

' Set RTB to measured height plus a fudge factor for Appearance rtfThreed and BorderStyle rtfFixedSingle
RichTextBox1.Height = MeasuredHeight + 8 * GetSystemMetrics(SM_CXBORDER) * Screen.TwipsPerPixelX 'Added to cater for X-borders; this is just a fudge. We should really deal with this in the measuring function
RichTextBox1.SelStart = 0 ' Need to do something this to get the text repositioned correctly
End Sub

Private Sub Form_Load()
RichTextBox1.Width = 5000
RichTextBox1.Text = ""
RichTextBox1.SelStart = 65536
RichTextBox1.SelFontName = "Arial"
RichTextBox1.SelText = "Now "
RichTextBox1.SelFontName = "Verdana"
RichTextBox1.SelFontSize = 24
RichTextBox1.SelText = "is the winter "
RichTextBox1.SelFontSize = 36
RichTextBox1.SelText = "of our "
RichTextBox1.SelFontName = "Times New Roman"
RichTextBox1.SelText = "discontent."
End Sub