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
Reply With Quote
