Fit to Text

I need to have a richtextbox fit to text... in other words I need it's height to adjust according to how much text is in it. And it will have different font sizes in it so it isn't just a matter of getting the lines and and font size multipling the font sizes by screen.twipsperpixely and off you go. Any ideas on how to go about that?

Thanks...

BestCoder

It's messy but you can use GetTextMetrics to get the height of a given font in your control. You have to know what fonts are on what line in the RTB.

Sample code:

http://www.allapi.net/apilist/exampl...0Small%20Fonts

You could try this:

VB Code:

Private Sub RichTextBox1_Change()
    RichTextBox1.Width = RichTextBox1.Container.TextWidth(RichTextBox1.Text) * 1.1
End Sub

Its not perfect but it works.

Here's some code I've used to set the RIchText box height to match the contents. I haven't included all the API declarations or constnats - they are easy enought ot find in the API viewer. Returns the height in twips.

VB Code:

Private Function CalculateTextHeight(pobjRTF As RichTextBox, pobjPic As PictureBox) As Long
 
    'Calcualtes the height of the text in a rich text box
    Dim lLines As Long
    Dim lIndex As Long
    Dim lMax As Long
    Dim lCurrentLine As Long
    Dim lMaxLineHeight As Long
    Dim lTotalLineHeight As Long
    Dim lCharLine As Long
    Dim lCharHeight As Long
    Dim lFont As StdFont
    Dim lSize As SIZEL
    Dim lLastFont As Font
    
    LockWindowUpdate pobjRTF.hwnd
    
    lLines = SendMessage(pobjRTF.hwnd, EM_GETLINECOUNT, 0, 0)
    lMax = Len(pobjRTF.Text)
    
    For lIndex = 0 To lMax
        'See if the current char
        'is on a new line
        lCharLine = SendMessage(pobjRTF.hwnd, EM_LINEFROMCHAR, lIndex, 0)
        If lCharLine > lCurrentLine Then
            If lMaxLineHeight = 0 Then
                'Must have been a blank space,
                GetTextSize pobjPic.hdc, lLastFont, "A", lSize
                lMaxLineHeight = lSize.cy
            End If
            lCurrentLine = lCurrentLine + 1
            lTotalLineHeight = lTotalLineHeight + lMaxLineHeight
            lMaxLineHeight = 0
        End If
        'Get the characters font
        pobjRTF.SelStart = lIndex
        pobjRTF.SelLength = 1
        Set lFont = New StdFont
        lFont.Name = pobjRTF.SelFontName
        lFont.Size = pobjRTF.SelFontSize
        lFont.Bold = pobjRTF.SelBold
        lFont.Underline = pobjRTF.SelUnderline
        lFont.Italic = pobjRTF.SelItalic
        Set pobjPic.Font = lFont
        GetTextSize pobjPic.hdc, lFont, pobjRTF.SelText, lSize
        
        If lSize.cy > lMaxLineHeight Then
            lMaxLineHeight = lSize.cy
        End If
        'Store the old font
        Set lLastFont = lFont
    Next lIndex
    
    'Get the final line info
    If lMaxLineHeight = 0 Then
        'Must have been a blank space,
        GetTextSize pobjPic.hdc, lLastFont, "A", lSize
        lMaxLineHeight = lSize.cy
    End If
    lTotalLineHeight = lTotalLineHeight + lMaxLineHeight
    
    LockWindowUpdate 0
    'Return the value
    CalculateTextHeight = lTotalLineHeight
    
    
End Function
 
Public Sub GetTextSize(phBufferDC As Long, pobjFont As StdFont, pstrText As String, ByRef pusrSize As SIZEL)
    Dim hFont As Long
    Dim hOldFont As Long
    Dim lSize As SIZEL
    Dim strText As String
    'Retrieve the handle of the new font
    hFont = CreateFont(phBufferDC, pobjFont, 0)
    'Select the font into the device context
    hOldFont = SelectObject(phBufferDC, hFont)
 
    strText = pstrText
    'Calculate the text size
    GetTextExtentPoint32 phBufferDC, strText, Len(strText), lSize
 
    pusrSize = lSize
    'Release the old font
    hFont = SelectObject(phBufferDC, hOldFont)
    'Delete the font handle
    DeleteObject hFont
 
End Sub
 
Public Function CreateFont(phDestDC As Long, ByVal pFont As Font, pRotation As Long) As Long
    'Entry point for the font creation
    'procedure
    Dim lf As LogFont
    Dim hwnd As Long
    Dim hdc As Long
    Dim lFont As StdFont
    
    hwnd = GetDesktopWindow
    hdc = GetDC(hwnd)
    
    'Copy the passed in font into the local font
    Set lFont = New StdFont
    With lFont
        .Bold = pFont.Bold
        .Charset = pFont.Charset
        .Italic = pFont.Italic
        .Name = pFont.Name
        .Size = pFont.Size
        .Strikethrough = pFont.Strikethrough
        .Underline = pFont.Underline
        .Weight = pFont.Weight
    End With
    
    
    With lf
        '
        ' All but two properties are very straight-forward,
        ' even with rotation, and map directly.
        '
        .lfHeight = -(lFont.Size * GetDeviceCaps(hdc, LOGPIXELSY)) / 72
        .lfWidth = 0
        .lfEscapement = pRotation * 10
        .lfOrientation = .lfEscapement
        .lfWeight = lFont.Weight
        .lfItalic = lFont.Italic
        .lfUnderline = lFont.Underline
        .lfStrikeOut = lFont.Strikethrough
        .lfClipPrecision = CLIP_DEFAULT_PRECIS
        .lfQuality = PROOF_QUALITY
        .lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE
        .lfFaceName = lFont.Name & vbNullChar
        '
        ' OEM fonts can't rotate, and we must force
        ' substitution with something ANSI.
        '
        .lfCharSet = lFont.Charset
        If .lfCharSet = OEM_CHARSET Then
            If (pRotation Mod 360) <> 0 Then
                .lfCharSet = ANSI_CHARSET
            End If
        End If
        '
        ' Only TrueType fonts can rotate, so we must
        ' specify TT-only if angle is not zero.
        '
        If (pRotation Mod 360) <> 0 Then
            .lfOutPrecision = OUT_TT_ONLY_PRECIS
        Else
            .lfOutPrecision = OUT_DEFAULT_PRECIS
        End If
    End With
    
    CreateFont = CreateFontIndirect(lf)
    
    Call ReleaseDC(hwnd, hdc)
    
    
End Function

As you can see, it basically loops through the text and determines the maximum height of each line. You should be able to use some of the text box API calls to do this instead, but I cpould never get the damn things to work properly, so I did it this way. Obviously, it's not blindingly fast, and is probably only suited to small amounts of text (I use it to calculate classifed newspaper ad heights which generally don't have more than a couple of hundred characters).

- gaffa

Thanks gaffa... I'll give that a try in the morning...

Cheers :)

If you play around with the code, be a bit careful with the GetTextSize and CreateFont functions - you need to make sure you are cleaning up all the handles properly, or you start leaking memory, and you app will go haywire...

- gaffa

Hey gaffa... I don't know what made me think of it but as I was in bed last night I had a brilliant idea... I thought "Oh yeah, the scollbars!" The scrollbars maximum position value changes with the amount of text in the control. Therefore if we could get the value of that we could adjust our height accordingly. So here is a little function that I did up. I haven't tested it extensively yet but as far as I can tell it works just fine. It uses the API function GetScrollRange and constant SB_VERT; I think they are available in the API Viewer but if not they are in the winuser.h file. Also the scrollbars property may have to be set vertical... I am not sure.

VB Code:

Public Sub AdjustHeight(ByVal rtfRichEdit As RichTextLib.RichTextBox, ByVal lpMinHeight As Long)
    Dim lpMax As Long    ' Max scroll position
    Dim lpMin As Long    ' Min scroll position
    
    ' get the scroll range
    GetScrollRange rtfRichEdit.hwnd, SB_VERT, lpMin, lpMax
    
    ' It may not be necessary to subtract the lpMin value from lpMax because I can't think of anytime that lpMin would be anything but 0... but just in case....
    If ((lpMax - lpMin) * Screen.TwipsPerPixelY < lpMinHeight) Then
       ' This allows you to set a minimum height for your control
        rtfRichEdit.Height = lpMinHeight
    Else
       ' Else the control height should be equal to the text height - the max scroll value.
        rtfRichEdit.Height = (lpMax - lpMin) * Screen.TwipsPerPixelY
    End If
End Sub

Anyway... I don't know if this will work for your situation but it works for mine and it is pretty fast. But thanks for offering your code...

Cheers :)

BestCoder

VB Code:

RichTextBox1.Height = Me.TextHeight(RichTextBox1.Text) + 150

That works for me

Well some variation of that would probably work for me if all of the text was the same font and size. But in my case it isn't.

Woops, sorry man, I forgot to test it with different font sizes :(