|
-
Dec 7th, 2024, 08:07 PM
#41
Thread Starter
Fanatic Member
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
I am sorry to bother, but can somehelp help me?
I can't wrap my head around this.
When I try to incorporate a minium font size, I wreck up the code.
Specially, the word wrap function no longer works, and the text is aligned on the top.
I understand why this happens (because I basically render the word wrap function useless by just overwriting the font size), but I don't know how to include the minimum font size approach correctly while keeping the logic of the existing code intact.
Thank you!
-
Dec 11th, 2024, 08:04 AM
#42
Thread Starter
Fanatic Member
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
This is my current version. The problem is that my brain can not imagine the possible mathematical situations, I guess. That is why I find it extremely difficult to solve this.
And since I think I have to use a Do Loop, I am scared.
If anybody who experiences fun analyzing such code would confirm it's ok, then it would be nice.
Thank you.
Code:
Public Function SetOptimalFSForTextRect(ByRef uMaxFontSize As Double, _
ByRef CC As cCairoContext, _
s As String, _
ByVal W As Double, _
ByVal h As Double, _
ByVal uInnerSpace As Long, _
ByVal uFontName As String, _
ByVal uColor As Long, _
ByVal uBold As Boolean, _
ByVal uItalic As Boolean, _
ByVal uUnderline As Boolean, _
ByVal uStrikethrough As Boolean, _
ByVal uSingleLine As Boolean) As Double
' Define the minimum font size
Dim minFontSize As Double
minFontSize = 5
Dim dblInitialMaxFontsize As Double
dblInitialMaxFontsize = uMaxFontSize
' Set the initial font size and the adjustment delta
Dim currentFontSize As Double
currentFontSize = 64
If uMaxFontSize > 0 Then
currentFontSize = uMaxFontSize
dblInitialMaxFontsize = uMaxFontSize
End If
Dim adjustmentDelta As Double
adjustmentDelta = uMaxFontSize - minFontSize
' Variables for calculating the text layout
Dim RowsCharCount() As Long ' Number of characters per row
Dim RowsCharOffset() As Long ' Character offsets for each row
Dim RowCount As Long ' Total number of rows
Dim MaxRowExtents As Single ' Maximum width of the text (extents)
Dim dblFontSize As Double
Dim textHeight As Double
' Loop to adjust the font size until it fits within the given width and height
Do Until Abs(adjustmentDelta) < 0.5
Dim totalFontSize As Double
totalFontSize = minFontSize + currentFontSize
dblFontSize = totalFontSize
If dblFontSize > uMaxFontSize Then
dblFontSize = uMaxFontSize
End If
CC.SelectFont uFontName, totalFontSize, uColor, uBold, uItalic, uUnderline
' Calculate the number of rows and the maximum text width based on the current font size
CC.CalcTextRowsInfo s, W - 2 * uInnerSpace, True, False, RowsCharCount, RowsCharOffset, RowCount, MaxRowExtents
' Calculate the total text height
textHeight = RowCount * CC.GetFontHeight
' Adjust the font size based on whether the text height exceeds the available height
If textHeight > h - 2 * uInnerSpace Then
adjustmentDelta = Abs(adjustmentDelta) * -0.5 ' Reduce font size
Else
adjustmentDelta = Abs(adjustmentDelta) * 0.5 ' Increase font size
End If
' Update the current font size with the adjustment
currentFontSize = currentFontSize + adjustmentDelta
'Not sure about this one...
If currentFontSize > uMaxFontSize Then
currentFontSize = uMaxFontSize
End If
Loop
Do
' If the text height is still too large after adjustment, reduce the font size slightly
If textHeight > h - 2 * uInnerSpace Then
currentFontSize = currentFontSize - 0.25
dblFontSize = minFontSize + currentFontSize
If dblFontSize < minFontSize Then
dblFontSize = minFontSize
Exit Do
End If
CC.SelectFont uFontName, dblFontSize, uColor, uBold, uItalic, uUnderline, False
' Calculate the number of rows and the maximum text width based on the current font size
CC.CalcTextRowsInfo s, W - 2 * uInnerSpace, True, False, RowsCharCount, RowsCharOffset, RowCount, MaxRowExtents
' Calculate the total text height
textHeight = RowCount * CC.GetFontHeight
Else
'at this point, dblFontSize might be 13.25 while uMaxFontSize is 10.
'Meaning we have a failure here if we don't do something. But currently I just exit the loop as I don't know what I should do.
Exit Do
End If
Loop
' additional "single-word-check" (decreasing the FontSize, when the max-extent of a single word is wider than W-2*Innerspace
Dim Words() As String, i As Long, WExt As Double, MaxWExt As Double
Words = Split(s, " ")
For i = 0 To UBound(Words) 'determine the max extent over all "single words"
WExt = CC.GetTextExtents(Words(i))
If MaxWExt < WExt Then MaxWExt = WExt
Next
If MaxWExt > W - 2 * uInnerSpace Then
dblFontSize = (minFontSize + currentFontSize) / MaxWExt * (W - 2 * uInnerSpace) * 0.92
CC.SelectFont uFontName, dblFontSize, uColor, uBold, uItalic, uUnderline
CC.CalcTextRowsInfo s, W - 2 * uInnerSpace, True, False, RowsCharCount, RowsCharOffset, RowCount, MaxRowExtents
textHeight = RowCount * CC.GetFontHeight ' Re-Calculate the total text height
End If
If textHeight > CC.Surface.Height Then
If dblFontSize = minFontSize Then
'cant do anything I guess. We are the minimum font size and still dont fit
Else
Debug.Assert False
End If
End If
'Not sure about this one...
If dblFontSize > dblInitialMaxFontsize Then
If dblInitialMaxFontsize > 0 Then
dblFontSize = dblInitialMaxFontsize
CC.SelectFont uFontName, dblFontSize, uColor, uBold, uItalic, uUnderline
End If
End If
uMaxFontSize = dblFontSize
SetOptimalFSForTextRect = textHeight ' Return the last determined textHeight
End Function
Tags for this Thread
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|