-
RC6 cCairoSurface: Implementing a "biggest font size available" logic
Hello!
I am in the process of removing all of my custom made DrawTextW etc. code since all that is available in a very intelligent way in RC6 cCairoSurface.
I am tempted to use my old code to establish the biggest available font size for a given rect and given textdraw flags which is stated below.
Now that I work mainly with the cCairoSurface object, I am not dealing with DCs so much anymore.
In my function below I use a DC as the text needs to be drawn onto something.
My best guess is that I should not use cCairoSurface's GetDC for that?
Thank for any advice on optimizating resources and speed in this case.
Code:
Public Function GetGoodFontSize(ByVal uHDC As Long, ByVal uText As String, ByRef uStdFont As StdFont, ByRef uAvailRect As RECT, ByVal uDrawTextFlags As DrawTextFlags, Optional ByVal uMaxFontSize As Long = 100) As Double
Dim lTries&
lTries = 0
Dim rCalc As RECT
Dim iSize&
Dim lGoodSize&
Dim iAvailWidth&
Dim iAvailHeight&
Dim iWidth As Long
Dim iHeight As Long
Dim iMax As Long
Dim iMin As Long
Dim tLF As LOGFONT
Dim hFnt&
Dim hFntOld&
Dim devcaps_LOGPIXELSY&
pOLEFontToLogFont uStdFont, uHDC, tLF ' setzen der werte, in der Schleife wird dann nur Groesse direkt upgedated
iAvailWidth = (uAvailRect.Right - uAvailRect.Left) 'wieviel Platz wir zum Zeichnen haben: Weite
iAvailHeight = (uAvailRect.Bottom - uAvailRect.Top) 'wieviel Platz wir zum Zeichnen haben: Height
iMax = 400&
If uMaxFontSize > 0 Then
iMax = uMaxFontSize
End If
iMin = 6&
lGoodSize = iMin
iSize = 24 '/Initial size; Gute werte fuer startwert, min/max koennen evtl. viel bringen
' bei startwert 24 und max 400 sind bei schriftgroesse =>24 wohl geschwindigkeitseinschraenkungen
If iSize > iMax Then
iSize = iMax
End If
devcaps_LOGPIXELSY = GetDeviceCaps(uHDC, LOGPIXELSY)
Do
lTries = lTries + 1
If lTries > 100 Then
Debug.Assert False
Exit Do
End If
tLF.lfHeight = -MulDiv(iSize, devcaps_LOGPIXELSY, 72&) ' groesse wie bei pOLEFontToLogFont
hFnt = CreateFontIndirect(tLF) 'Create new font
hFntOld = SelectObject(uHDC, hFnt)
' Rechteeck zuruecksetzen (v.a. .Right !!!)
rCalc.Left = 0&
rCalc.Top = 0&
rCalc.Right = iAvailWidth
rCalc.Bottom = iAvailHeight
Call DrawTextW(uHDC, StrPtr(uText), -1, rCalc, uDrawTextFlags Or DT_CALCRECT)
iWidth = (rCalc.Right - rCalc.Left)
iHeight = (rCalc.Bottom - rCalc.Top)
'Berechnung/Vergleich, ueber Mittelwert (bzw. Startwert), aehnlich wie Zahlenraten.
If (iMax = iMin) Then
Exit Do
Else
If (iWidth > iAvailWidth) Or (iHeight > iAvailHeight) Then
If iMax - iMin < 2& Then
iMax = iMax - 1&
iSize = iMax
Else
iMax = iSize
iSize = ((iMax + iMin) \ 2&)
End If
Else
lGoodSize = iSize
If iMax - iMin < 2 Then
iMin = iMin + 1
iSize = iMin
Else
iMin = iSize
iSize = ((iMax + iMin) \ 2&)
End If
End If
End If
SelectObject uHDC, hFntOld
hFntOld = 0
DeleteObject hFnt
hFnt = 0
Loop
GetGoodFontSize = lGoodSize
End Function
Public Sub pOLEFontToLogFont(fntThis As StdFont, hdc As Long, tLF As LOGFONT)
Dim sFont$
Dim iChar%
' Convert an OLE StdFont to a LOGFONT structure:
With tLF
sFont = fntThis.Name
' There is a quicker way involving StrConv and CopyMemory, but
' this is simpler!:
For iChar = 1 To Len(sFont)
.lfFaceName(iChar - 1) = CByte(Asc(VBA.Mid(sFont, iChar, 1)))
Next iChar
' Based on the Win32SDK documentation:
.lfHeight = -MulDiv((fntThis.Size), (GetDeviceCaps(hdc, LOGPIXELSY)), 72)
.lfItalic = fntThis.Italic
If (fntThis.Bold) Then
.lfWeight = FW_BOLD
Else
.lfWeight = FW_NORMAL
End If
.lfUnderline = fntThis.Underline
.lfStrikeOut = fntThis.Strikethrough
' Fix to ensure the correct character set is selected. Otherwise you
' cannot display Wingdings or international fonts:
.lfCharSet = fntThis.CharSet
.lfQuality = 6
End With
End Sub
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
You have to describe in more detail, what you want to achieve -
since a cCairoContext (the usual "CC") does have a nice ScaleDrawings-Method already built-in.
Meaning, that for "static Texts" which fit a certain DPI, you just have to set the Scale properly when the DPI is different from the default-DPI of 96dpi-
so that FontSize-adaptions are normally not necessary...
Could you provide a fully working example (as a zipped Project), what you currently do via GDI?
Olaf
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Yes, here it is.
Thank you for any suggestion if you have any ideas for optimization or my use of cCairo classes.
Edit: Please use the new version of the project only.
-
1 Attachment(s)
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Here is a new version of the project.
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Quote:
Originally Posted by
tmighty2
Here is a new version of the project.
Ok, since it seems the Text-Content (per Cell) is dynamic -
manipulating the FontSize (instead of using CC.ScaleDrawings) is the better idea.
Here you go (using the built-in "WordBreak"-calculation algo CC.CalcTextRowsInfo)...
Into a virginal Form (with an RC6-Reference):
Code:
Option Explicit
Private mCC As cCairoContext, sText As String
Private Sub Form_Load()
sText = Replace("This is a longer text that should fill the entire rect.\r\n\r\nWhy?\r\n\r\n" & _
"Imagine a grid with a variable number of rows and cols, and the text each of grid cell should be as big as possible.", "\r\n", vbCrLf)
End Sub
Private Sub Form_Resize()
ScaleMode = vbPixels
Set mCC = Cairo.CreateSurface(ScaleWidth, ScaleHeight).CreateContext
ReDraw
End Sub
Sub ReDraw()
mCC.Paint 1, Cairo.CreateSolidPatternLng(vbWhite) 'erase/repaint the whole surface with solid white
New_c.Timing True
SetOptimalFSForTextRect mCC, sText, mCC.Surface.Width, mCC.Surface.Height, 4, "Arial", vbBlack, True, True
Caption = New_c.Timing
mCC.DrawText 0, 0, mCC.Surface.Width, mCC.Surface.Height, sText, False, vbLeftJustify, 4
Set Picture = mCC.Surface.Picture
End Sub
Function SetOptimalFSForTextRect(CC As cCairoContext, S As String, ByVal W As Double, ByVal H As Double, _
Optional ByVal InnerSpace&, Optional FName$ = "Arial", Optional ByVal FColor&, _
Optional ByVal FB As Boolean, Optional ByVal FI As Boolean, Optional ByVal FU As Boolean) As Double
Dim minSZ As Double: minSZ = 5
Dim curSZ As Double: curSZ = 64
Dim curDS As Double: curDS = 64
Do Until Abs(curDS) < 0.5
CC.SelectFont FName, minSZ + curSZ, FColor, FB, FI, FU
Dim RowsCharCount() As Long, RowsCharOffset() As Long, RowCount As Long, MaxRowExtents As Single '<-ByRef-Parms
CC.CalcTextRowsInfo S, W - 2 * InnerSpace, True, False, RowsCharCount, RowsCharOffset, RowCount, MaxRowExtents
curDS = Abs(curDS) * IIf(RowCount * CC.GetFontHeight > H - 2 * InnerSpace, -0.5, 0.5)
curSZ = curSZ + curDS
Loop
If RowCount * CC.GetFontHeight > H - 2 * InnerSpace Then 'still too large?
curSZ = curSZ - 0.25
CC.SelectFont FName, minSZ + curSZ, FColor, FB, FI, FU
End If
SetOptimalFSForTextRect = curSZ 'return the last set FontSize
End Function
Olaf
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
I would like to replace my code with yours.
However, I don't see what I need to do align the text top left.
Can you please tell me?
I need to be able to align the text on the left top both when I use single line and not single line.
Thank you very much.
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Can you also tell me how to get the rectangle that is used be the font in your code?
I was assuming to see something like DrawText API where the given rect is even changed accordingly after the rendering. I need this rect to know where the text was drawn.
I need more time to understand your code, and while I am a bit under time pressure, that would be a great help. Thank you in advance.
ps: I tried it, and my rectangle doesn't match what I see regarding your font on the screen.
-
2 Attachment(s)
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
I have attached yet another sample.
The top of the font (where it is drawn on the screen) confuses me.
I thought I could calculate where the text is drawn when it is always v centered, but it seems it is not.
Thank you for you having a look at my sample project. Perhaps I made a mistake somewhere.
The red rectangle is where I calculated where the text would be drawn. It is off...
Attachment 192887
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Could you please tell me what the the return value of DrawText means? Does it mean the number of lines drawn?
And I noticed that the Byref Param maxDxNeeded is always empty.
Thank you.
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Quote:
Originally Posted by
tmighty2
Could you please tell me what the the return value of DrawText means? Does it mean the number of lines drawn?
Yes - multiplied with the CC.FontHeight it is the height of the occupied Rectangle.
Quote:
Originally Posted by
tmighty2
And I noticed that the Byref Param maxDxNeeded is always empty.
In "Word-Break-Mode" the max. DX needed is identical with the desired dx-Width the Text should "break on".
Only in "SingleLine"-mode will the maxDxNeeded-Param returned/filled.
------------------------------------
As for your previous problem - here is corrected Form-Code.
Code:
Option Explicit
Private mCC As cCairoContext, sText As String
Private Sub Form_Load()
sText = Replace("This is a longer text that should fill the entire rect.\r\n\r\nWhy?\r\n\r\n" & _
"Imagine a grid with a variable number of rows and cols, and the text each of grid cell should be as big as possible.", "\r\n", vbCrLf)
Me.AutoRedraw = True
End Sub
Private Sub Form_Resize()
ScaleMode = vbPixels
Set mCC = Cairo.CreateSurface(ScaleWidth, ScaleHeight).CreateContext
ReDraw
End Sub
Sub ReDraw()
mCC.Paint 1, Cairo.CreateSolidPatternLng(vbWhite) 'erase/repaint the whole surface with solid white
Dim dblHeight As Double
New_c.Timing True
dblHeight = SetOptimalFSForTextRect(mCC, sText, mCC.Surface.Width, mCC.Surface.Height, 0, "Arial", vbBlack, True, True)
Caption = New_c.Timing
mCC.Save 'buffer the context, since we use a translate in the line below
mCC.TranslateDrawings 0, (mCC.Surface.Height - dblHeight) / 2
mCC.DrawText 0, 0, mCC.Surface.Width, mCC.Surface.Height, sText, False, , , , dtNormal
DrawRectangle mCC, 1, 0, mCC.Surface.Width - 2, dblHeight, 0, vbRed, 0.5, vbBlue, 0.8
mCC.Restore
mCC.Surface.DrawToDC Me.hDC, 0, 0
If Me.AutoRedraw Then Me.Refresh 'refresh only, when AutoRedraw=true
End Sub
Public Function SetOptimalFSForTextRect(CC As cCairoContext, s As String, ByVal W As Double, ByVal H As Double, _
Optional ByVal InnerSpace As Long = 0, _
Optional FName As String = "Arial", _
Optional ByVal FColor As Long = vbBlack, _
Optional ByVal FB As Boolean = False, _
Optional ByVal FI As Boolean = False, _
Optional ByVal FU As Boolean = False) As Double
' Define the minimum font size
Dim minFontSize As Double
minFontSize = 5
' Set the initial font size and the adjustment delta
Dim currentFontSize As Double
currentFontSize = 64
Dim adjustmentDelta As Double
adjustmentDelta = 64
' 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 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
CC.SelectFont FName, totalFontSize, FColor, FB, FI, FU
' Calculate the number of rows and the maximum text width based on the current font size
CC.CalcTextRowsInfo s, W - 2 * InnerSpace, 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 * InnerSpace 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
Loop
' If the text height is still too large after adjustment, reduce the font size slightly
If textHeight > H - 2 * InnerSpace Then
currentFontSize = currentFontSize - 0.25
CC.SelectFont FName, minFontSize + currentFontSize, FColor, FB, FI, FU
' Calculate the number of rows and the maximum text width based on the current font size
CC.CalcTextRowsInfo s, W - 2 * InnerSpace, True, False, RowsCharCount, RowsCharOffset, RowCount, MaxRowExtents
' Calculate the total text height
textHeight = RowCount * CC.GetFontHeight
End If
SetOptimalFSForTextRect = textHeight ' Return the last determined textHeight
End Function
Private Sub ClearContext(ByRef CC As cCairoContext)
CC.Operator = CAIRO_OPERATOR_CLEAR
CC.Paint
CC.Operator = CAIRO_OPERATOR_OVER 'reset to the default-operator
End Sub
Private Sub FillCairoContextWithSolidColor(ByRef CC As cCairoContext, ByVal uColor As Long)
CC.Paint 1, Cairo.CreateSolidPatternLng(uColor, 1)
End Sub
Olaf
-
2 Attachment(s)
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Can you please tell me how to avoid line breaks within words like these?
Attachment 192926
I have attached the current version of the project.
Thank you!
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Could you also show me how to implement a "MaxFontSize" value?
I would like to make it so that uFontSize (the first argument serves as the maximal font size):
Code:
Public Function SetOptimalFSForTextRect(ByRef uMaxFontSize As Double, ByRef CC As cCairoContext, s As String, ByVal w As Double, ByVal h As Double, _
Optional ByVal InnerSpace As Long = 0, _
Optional FName As String = "Arial", _
Optional ByVal FColor As Long = vbBlack, _
Optional ByVal FB As Boolean = False, _
Optional ByVal fi As Boolean = False, _
Optional ByVal FU As Boolean = False) As Double
Thank you.
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Quote:
Originally Posted by
tmighty2
Could you also show me how to implement a "MaxFontSize" value?
I would like to make it so that uFontSize (the first argument serves as the maximal font size):
Code:
Public Function SetOptimalFSForTextRect(ByRef uMaxFontSize As Double, ByRef CC As cCairoContext, s As String, ByVal w As Double, ByVal h As Double, _
Optional ByVal InnerSpace As Long = 0, _
Optional FName As String = "Arial", _
Optional ByVal FColor As Long = vbBlack, _
Optional ByVal FB As Boolean = False, _
Optional ByVal fi As Boolean = False, _
Optional ByVal FU As Boolean = False) As Double
Thank you.
The DeltaFontsize in my example was hardwired to 64 IIRC (then going down towards zero in a few iterations)...
DeltaFontsize = MaxFontsize - MinFontsize
As for the Wordbreak-Algo - I'm not planning to introduce a new flag for "don't break on too long single-words" -
since - as it currently is - too long single-words will remain at least "decipherable" (with their non-fitting "overhang" being reflected on the next line).
Olaf
-
1 Attachment(s)
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Please allow me to show you a few quickly cropped screenshots of what I am fighting with.
I must say that I have not studied the mechanisms of DrawText API which I previously used, but using the flags that it offered like DT_WORDBREAK, I was able to get a nice font layout.
I am currently unable to achieve this with the RC6 methods.
In the case of "Schnelle Kommentare", I am lost about what I should do.
ps: What I did with DrawText in my old version was to limit the font size. I asked about it because my attempts destroy your code, and I end up with something bad. Honestly I only start to understand some of your codes after reading them again and again and trying them in different situations, and I am currently not in a situation where I have this time, that is why I asked about it. Not because of laziness.
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Quote:
Originally Posted by
tmighty2
I must say that I have not studied the mechanisms of DrawText API which I previously used,
but using the flags that it offered like DT_WORDBREAK, I was able to get a nice font layout.
Are you sure, because I think you'd have ended up with:
Schnelle
Komment
Or in case of DT_ENDELLIPSIS:
Schnelle
Komme...
...cutting off the end of the single-line-word...
IMO, you have to provide a better Aspect-Ratio for your Text-Rectangles (with a shorter Height compared to its Width) -
basically what you did with the "House-Icon" (on top of the then height-reduced Text-Rect below it, resulting in a smaller Font).
Alternatively, you could try to implement your own Pre- and Post-Processing
(but that would require a Syllables-Database, used in conjunction with that -
basically mimicking what "larger Word-Processors do" (as e.g. Libre-Office, MS-Word etc.).
Olaf
-
1 Attachment(s)
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
I don't have real control over the layout. People expect it to be "just right".
It's a software for cognitively disabled people. As they make things harder to understand, I try to avoid (syllable) breaks.
The "good layout" is not suitable for most as the font needs to be a big as possible.
Would you be willing to help me with the Maximum Font Size thing?
I am a bit smarter than chatgpt, but I still don't get the job done.
This one is driving me insane:
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
You can solve this directly within the existing Function -
by just checking yourself - whether "single-words" exceed the current desired Width.
Just put in the following into the function, shortly before leaving it:
Code:
...
' 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 * InnerSpace Then
CC.SelectFont FName, (minFontSize + currentFontSize) / MaxWExt * (W - 2 * InnerSpace) * 0.92, FColor, FB, FI, FU
CC.CalcTextRowsInfo s, W - 2 * InnerSpace, True, False, RowsCharCount, RowsCharOffset, RowCount, MaxRowExtents
textHeight = RowCount * CC.GetFontHeight ' Re-Calculate the total text height
End If
SetOptimalFSForTextRect = textHeight ' Return the last determined textHeight
End Function
Olaf
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
After a tap / click on a cell in such a grid cell, I make the cell "flash" using a red background color and a white text which fades out with time.
For this purpose, I need to draw the same text using the same font, but using a different color.
I draw it on a new surface/context combo and then render it each 20 ms with an alpha value which goes 0 over time.
You proposed a new function "SetOptimizedFontsize..." instead of going with my "GetBestFontsize..." function which returns the font size.
I am not fully aware of how cCairoContext works. I only noticed that it lives on even when cCairoSurface has been destroyed.
Can you advise me how to deal with my task where I need to draw the same text using a different font color but same font and size?
I like the new "SetOptimizedFontSize" function, and I wonder what you would do in such a situation instead of changing it so that it returns the font size to the "outer world".
Thank you.
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Olaf, could you explain the vertical alignment parameter in DrawText? It is number instead of an enum.
I am fighting with a y offset that I can not explain, and I play with all parameters.
On the one hand there is the vertical alignment parameter, but still (in the code above) you instead translate the drawing.
Can you shed light on this? Thank you.
(And also "innerspace" which you sometimes use 4 for, sometimes 0...)
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Quote:
Originally Posted by
tmighty2
You proposed a new function "SetOptimizedFontsize..." instead of going with my "GetBestFontsize..." function which returns the font size.
...
I like the new "SetOptimizedFontSize" function, and I wonder what you would do in such a situation instead of changing it so that it returns the font size to the "outer world".
In case of repeated redrawings of the Text (without changing the TextString) -
having the current Fontsize available on the outside is helpful to save CPU-cycles...
So, why not pass an additional ByRef LastSetFontSize-Param along into the SetOptimizedFontsize-function.
Quote:
Originally Posted by
tmighty2
I am not fully aware of how cCairoContext works. I only noticed that it lives on even when cCairoSurface has been destroyed.
It always starts with a Surface (which a context can be derived from at any time).
Since a Context without a Surface does not make any sense - an internal mSrf-Variable
(of the Surface this context was derived from) is kept alive as a Reference until the ContextObj dies...
So, removing a reference to an "isolated" (standalone) Surface-Object on the outside,
does not make that Surface-instance die, as long as "derived Contexts" exist -
(from which you can "restore" (or access) the original Surface at any time via CC.Surface...)
As for VAlign - it (currently) supports only two "states" (Off == top-aligned == 0) and "On == v-centered for any value <> 0.
InnerSpace works exactly as you'd expect (reserving "padding-space" on all four (inner)sides of the DrawText-Rectangle).
Just experiment a bit more with those Params, to get a better feeling for them.
Olaf
-
1 Attachment(s)
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Thank you.
I am sorry to ask, but I just can't wrap my head around what you do when you select the font properties.
I am using the same values to return them to the outside, but when I do, the draw area exceeds the surface space.
I didn't manage to directly include the font size that should be returned (I named it uMaxFontSize, and I use it for possible max font size and as the determined max font size of the function), so I introduced an intermediate variable named "dblCur".
However, when I use it, I am confused because you seem in one step of the function you diminish the current font size:
Code:
currentFontSize = currentFontSize - 0.25
but that is not what you select for the font. Instead you do this:
Code:
CC.SelectFont uFontName, minFontSize + currentFontSize, uColor, uBold, uItalic, uUnderline
So I don't know what to return.
When I tried to change your function, I made it disfunctional as explained above.
Would you be willing to take a look where I went wrong?
Thank you.
Code:
Public Function SetOptimalFSForTextRect(ByRef uMaxFontSize As Double, ByRef CC As cCairoContext, ByVal s As String, ByVal w As Double, ByVal h As Double, _
Optional ByVal uInnerSpace As Long = 0, _
Optional ByVal uFontName As String = "Arial", _
Optional ByVal uColor As Long = vbBlack, _
Optional ByVal uBold As Boolean = False, _
Optional ByVal uItalic As Boolean = False, _
Optional ByVal uUnderline As Boolean = False) As Double
'Possible future "look-up" function, not implemented yet
Dim sIdentifier$
sIdentifier = uMaxFontSize & "|" & CC.Surface.Width & "|" & CC.Surface.Height & "|" & s & "|" & w & "|" & h & "|" & uFontName & "|" & uBold & "|" & uItalic & "|" & uUnderline
Dim bFound As Boolean
bFound = False
If bFound Then
CC.SelectFont uFontName, uMaxFontSize, uColor, uBold, uItalic, uUnderline
Exit Function
End If
'End of possible future lookup function
' Define the minimum font size
Dim minFontSize As Double
minFontSize = 5
' Set the initial font size and the adjustment delta
Dim currentFontSize As Double
currentFontSize = 64
Dim adjustmentDelta As Double
If uMaxFontSize > 0 Then
adjustmentDelta = uMaxFontSize
Else
adjustmentDelta = 64
End If
' 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 dblCur As Double
dblCur = currentFontSize
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
dblCur = totalFontSize
CC.SelectFont uFontName, dblCur, 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
dblCur = currentFontSize
Loop
' 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
dblCur = currentFontSize
CC.SelectFont uFontName, minFontSize + currentFontSize, 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
End If
' 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
Debug.Assert dblCur = currentFontSize
dblCur = (minFontSize + currentFontSize) / MaxWExt * (w - 2 * uInnerSpace) * 0.92
'you set this font size
CC.SelectFont uFontName, dblCur, 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
Debug.Assert textHeight <= CC.Surface.Height
End If
uMaxFontSize = dblCur
Debug.Assert textHeight <= CC.Surface.Height
SetOptimalFSForTextRect = textHeight ' Return the last determined textHeight
End Function
Edit:
I have attached the full sample project with all the suggestions received and a combobox to select the vertical alignment.
-
1 Attachment(s)
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
I notice a gap in some situations. Could you have a look at my sample project to see what is happening here? I don't understand it.
In the inserted screenshot you see 2 green arrows at the gaps.
Thank you very much for your help!
Attachment 193158
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Quote:
Originally Posted by
tmighty2
I notice a gap in some situations.
Please enhance the simplified word-splitter-codeline this way:
Words = Split(Replace(s, vbCrLf, " "), " ")
Olaf
-
1 Attachment(s)
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Thank you very much. I did it, but I am currently fighting with another problem.
I have included your change suggest, but the problem remains:
There is a situation where the text is not drawn onto the surface.
To be sure about it I check the surface using a "IsTransparent" function. I am not perfectly sure if the code is right, but it aligns with what I see: The text is not drawn.
Could you start the attached project and size the form manually? At some point you will see that the Debug.Assert hits.
That is when no text is drawn.
Thank you for having a look.
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Quote:
Originally Posted by
tmighty2
The text is not drawn.
The DrawText-function (when - as in your case - not in SingleLine-mode) -
suppresses text-render-output of lines, which do not fit in "height-wise" with the given rectangle.
DrawText in SingleLine-Mode on the other hand, will always force the output of that single line without any "Height-fit-in" considerations.
You can workaround that by setting SingleLine-Mode automatically beforehand.
Code:
Dim bSingleLine As Boolean: bSingleLine = mCC.Surface.Height < mCC.GetFontHeight + 0.5
mCC.DrawText 0, 0, mCC.Surface.Width, mCC.Surface.Height, sText, bSingleLine, hAlign, uInnerSpace, vAlign, dtNormal
Olaf
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
You are really most helpful. Thank you!
-
2 Attachment(s)
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
I am experiencing the same bug again when using vertical center alignment, but not when I use vertical top alignment.
I wonder what is different about these 2 options.
Would you be willing to take a look?
I have combined the 2 functions into a single function, and I have introduced Left and Top offset, and the sample project contains an inset option, but that does not contribute to the problem.
The problem occurs in the previous version as well.
May I ask you if you would also be willing to show how the max font size would be implemented correctly? I am using because I don't understand the lines where you set a new font size but do not store them.
Thank you very much.
Attachment 193172
Attachment 193168
-
1 Attachment(s)
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Olaf, could you perhaps show me how you would a "maximum font size" in the code below?
I am asking because my attempts fail, and I don't understand what you suggested regarding using the delta for that.
As suggested, I will return the resulting font size to the "outside world". That is why I use ByRef uMaxFontSize for input and for output.
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 uSingleline As Boolean) As Double
' Define the minimum font size
Dim minFontSize As Double
minFontSize = 5
' Set the initial font size and the adjustment delta
Dim currentFontSize As Double
currentFontSize = 64
Dim adjustmentDelta As Double
adjustmentDelta = 64
' 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 textHeight As Double
' Loop to adjust the font size until it fits within the given width and height
Dim dblCurDelta As Double
dblCurDelta = 0.5
Dim bTooHigh As Boolean
Dim bOnlyOnLineBreaks As Boolean
bOnlyOnLineBreaks = False
Do
Dim bLower As Boolean
bLower = Abs(adjustmentDelta) < dblCurDelta '0.5
If bLower Then
If uMaxFontSize > 0 Then
If currentFontSize > uMaxFontSize Then
dblCurDelta = Abs(dblCurDelta) / 2
If dblCurDelta < 0.1 Then
currentFontSize = uMaxFontSize
CC.SelectFont uFontName, currentFontSize, uColor, uBold, uItalic, uUnderline
CC.CalcTextRowsInfo s, w - 2 * uInnerSpace, Not uSingleline, bOnlyOnLineBreaks, RowsCharCount, RowsCharOffset, RowCount, MaxRowExtents
If uSingleline Then
Debug.Assert RowCount = 1
End If
textHeight = RowCount * CC.GetFontHeight ' Re-Calculate the total text height
Exit Do
Else
'go on
End If
Else
Exit Do
End If
Else
Exit Do
End If
End If
'DoEvents
Dim totalFontSize As Double
totalFontSize = minFontSize + currentFontSize
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, Not uSingleline, bOnlyOnLineBreaks, RowsCharCount, RowsCharOffset, RowCount, MaxRowExtents
' Calculate the total text height
textHeight = RowCount * CC.GetFontHeight
bTooHigh = False
If uSingleline Then
If RowCount > 1 Then
bTooHigh = True
End If
End If
' Adjust the font size based on whether the text height exceeds the available height
If (textHeight > h - 2 * uInnerSpace) Or (MaxRowExtents > w - 2 * uInnerSpace) Or bTooHigh Then
adjustmentDelta = Abs(adjustmentDelta) * -(dblCurDelta) '0.5 ' Reduce font size
Else
adjustmentDelta = Abs(adjustmentDelta) * (dblCurDelta) ' 0.5 ' Increase font size
End If
' Update the current font size with the adjustment
currentFontSize = currentFontSize + adjustmentDelta
Loop
' If the text height or width is still too large after adjustment, reduce the font size slightly
If textHeight > h - 2 * uInnerSpace Or MaxRowExtents > w - 2 * uInnerSpace Then
currentFontSize = currentFontSize - (dblCurDelta / 2) '0.25
CC.SelectFont uFontName, minFontSize + currentFontSize, 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, Not uSingleline, bOnlyOnLineBreaks, RowsCharCount, RowsCharOffset, RowCount, MaxRowExtents
' Calculate the total text height
textHeight = RowCount * CC.GetFontHeight
If uSingleline Then
Debug.Assert RowCount = 1
End If
End If
If Not uSingleline Then
' 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(Replace(s, vbCrLf, " "), " ")
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
CC.SelectFont uFontName, (minFontSize + currentFontSize) / MaxWExt * (w - 2 * uInnerSpace) * 0.92, uColor, uBold, uItalic, uUnderline
CC.CalcTextRowsInfo s, w - 2 * uInnerSpace, Not uSingleline, bOnlyOnLineBreaks, RowsCharCount, RowsCharOffset, RowCount, MaxRowExtents
textHeight = RowCount * CC.GetFontHeight ' Re-Calculate the total text height
End If
End If
If uMaxFontSize > 0 Then
Debug.Assert currentFontSize <= uMaxFontSize
End If
SetOptimalFSForTextRect = textHeight ' Return the last determined textHeight
End Function
Public Sub DrawTextEx(ByRef uMaxFontSize As Double, ByRef CC As cCairoContext, ByVal uText As String, ByVal uHAlign As AlignmentConstants, ByVal uVAlign As eVerticalAlignmentConstants, _
ByVal uLeft As Double, _
ByVal uTop As Double, _
ByVal uWidth As Double, _
ByVal uHeight As Double, _
ByVal uFontName As String, _
ByVal uColor As Long, _
ByVal uBold As Boolean, _
ByVal uItalic As Boolean, _
ByVal uUnderline As Boolean, _
ByVal uWithDropshadow As Boolean, _
ByVal uSingleline As Boolean)
Dim dblHeight As Double
dblHeight = SetOptimalFSForTextRect(uMaxFontSize, CC, uText, uWidth, uHeight, 0, uFontName, uColor, uBold, uItalic, uUnderline, uSingleline)
Dim dblYOffsetRed As Double
Dim dblYOffsetText As Double
If uVAlign = eVerticalAlignment_Olaf_Center Then
'no need to translate the rendering
dblYOffsetRed = (uHeight - dblHeight) / 2
dblYOffsetText = ((uHeight) / 2) - (dblHeight / 2)
ElseIf uVAlign = eVerticalAlignment_Olaf_Top Then
dblYOffsetRed = 0
dblYOffsetText = 0
ElseIf uVAlign = eVerticalAlignment_Bottom Then
dblYOffsetRed = uHeight - dblHeight
'The text rendering starts at the vertical middle of the surface
'and it is shifted vertically according to its height
'so the text drawing starts at surface/2
'- (textheight/2)
'if we want to align it on the bottom, we must do this:
'shift it so that it ends at the vertical middile:
dblYOffsetText = -(dblHeight / 2)
'and now add half the surface height
dblYOffsetText = dblYOffsetText + (uHeight / 2)
If dblYOffsetText > CC.Surface.Height Then
Debug.Assert False
End If
Else
Debug.Assert False
End If
'!!!!!!!! do not use the original vAlign!!!!
Dim lVAlign&
If uVAlign = eVerticalAlignment_Olaf_Center Then
lVAlign = 0 ' -1 ' 'VAlign - it (currently) supports only two "states" (Off == top-aligned == 0) and "On == v-centered for any value <> 0.
ElseIf uVAlign = eVerticalAlignment_Olaf_Top Then
lVAlign = 0 ' 'VAlign - it (currently) supports only two "states" (Off == top-aligned == 0) and "On == v-centered for any value <> 0.
ElseIf uVAlign = eVerticalAlignment_Bottom Then
'we need to calculate it ourselves
'so we use Olaf's top:
lVAlign = 0
End If
'VAlign - it (currently) supports only two "states" (Off == top-aligned == 0) and "On == v-centered for any value <> 0.
CC.Save 'buffer the context, since we use a translate in the line below
CC.TranslateDrawings 1, dblYOffsetText + 1
If uWithDropshadow Then
CC.Save
CC.SetLineCap CAIRO_LINE_CAP_ROUND
CC.SetLineJoin CAIRO_LINE_JOIN_ROUND
CC.SetLineWidth 1
CC.SetSourceColor uColor, 0.1 'make the font color transparent
CC.DrawText uLeft, uTop, uWidth, uHeight, uText, uSingleline, uHAlign, 0, lVAlign, dtNormal, 1, True
CC.SetLineWidth 3
CC.Stroke
CC.SetSourceColor uColor, 0.045
CC.DrawText uLeft, uTop, uWidth, uHeight, uText, uSingleline, uHAlign, 0, lVAlign, dtNormal, 1, True
CC.Fill
CC.Restore
End If
CC.DrawText uLeft, uLeft, uWidth, uHeight, uText, uSingleline, uHAlign, 0, lVAlign, dtNormal, 1 'der alphawert hat keinen einfluss auf setsourcecolor-alpha. es wird overrult! '0, 0, uText 'this is the final "on-top-Textout" which takes place in either case
CC.Restore
CC.Save 'buffer the context, since we use a translate in the line below
CC.TranslateDrawings 0, dblYOffsetRed
DrawRectangle CC, uLeft, uTop, uWidth - 2, uHeight - 2, 0, vbRed, 0.5, vbBlue, 0.8
CC.Restore
End Sub
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
The second parameter of CC.SelectFont (no matter, if passed as a single-Variable, or an Expression) -
needs to be reflected in your ByRef-Param uMaxFontSize ...
And since CC.SelectFont occurs 3 times in the function above -
you have to set uMaxFontSize 3 times (to whatever is passed in the 2nd Argument).
That's basic programming-stuff BTW... ;)
Olaf
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
In my test, the text box is vertically centered above and below.
In the process, it also produces a wrong drawing area, so it can't center itself.
In theory, if my text box height is 100 pixels, my font size can be set to 100.
But some fonts are actually 150 pixels high.
So I changed his font to 100 รท 1.5.
The font size may not be accurate, but it is basically fine tuned by hand.
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
-
1 Attachment(s)
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
My current problem is that the text height calculation fails when I combine the SetOptimalFontSizeForRect function with SingleLine, MaxFontSize and DropShadow (but I think DropShadow does not contribute to the problem).
I don't understand why.
A sample project is attached.
Olaf, the maximum font size is not trivial I think.
I am using a start adjustment delta of 0.5, and instead of exiting the loop when the adjustment delta is lower than 0.5, I divide adjustment delta by 2 until the font size is <= uMaxFontSize.
I guess this is where the text height measurement fails, but I am not sure.
I would appreciate it if you could take a look at my code and see if you spot any error. The project is attached.
Here is the relevant code:
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 uSingleline As Boolean) As Double
' Define the minimum font size
Dim minFontSize As Double
minFontSize = 5
' Set the initial font size and the adjustment delta
Dim currentFontSize As Double
currentFontSize = 64
Dim adjustmentDelta As Double
adjustmentDelta = 64
' 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 textHeight As Double
' Loop to adjust the font size until it fits within the given width and height
Dim dblCurDelta As Double
dblCurDelta = 0.5
Dim bTooHigh As Boolean
Dim bOnlyOnLineBreaks As Boolean
bOnlyOnLineBreaks = False
Do
Dim bLower As Boolean
bLower = Abs(adjustmentDelta) < dblCurDelta '0.5
If bLower Then
If uMaxFontSize > 0 Then
If currentFontSize > uMaxFontSize Then
dblCurDelta = Abs(dblCurDelta) / 2
If dblCurDelta < 0.1 Then
currentFontSize = uMaxFontSize
CC.SelectFont uFontName, currentFontSize, uColor, uBold, uItalic, uUnderline
CC.CalcTextRowsInfo s, w - 2 * uInnerSpace, Not uSingleline, bOnlyOnLineBreaks, RowsCharCount, RowsCharOffset, RowCount, MaxRowExtents
If uSingleline Then
Debug.Assert RowCount = 1
End If
textHeight = RowCount * CC.GetFontHeight ' Re-Calculate the total text height
Exit Do
Else
'go on
End If
Else
Exit Do
End If
Else
Exit Do
End If
End If
'DoEvents
Dim totalFontSize As Double
totalFontSize = minFontSize + currentFontSize
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, Not uSingleline, bOnlyOnLineBreaks, RowsCharCount, RowsCharOffset, RowCount, MaxRowExtents
' Calculate the total text height
textHeight = RowCount * CC.GetFontHeight
bTooHigh = False
If uSingleline Then
If RowCount > 1 Then
bTooHigh = True
End If
End If
' Adjust the font size based on whether the text height exceeds the available height
If (textHeight > h - 2 * uInnerSpace) Or (MaxRowExtents > w - 2 * uInnerSpace) Or bTooHigh Then
adjustmentDelta = Abs(adjustmentDelta) * -(dblCurDelta) '0.5 ' Reduce font size
Else
adjustmentDelta = Abs(adjustmentDelta) * (dblCurDelta) ' 0.5 ' Increase font size
End If
' Update the current font size with the adjustment
currentFontSize = currentFontSize + adjustmentDelta
Loop
' If the text height or width is still too large after adjustment, reduce the font size slightly
If textHeight > h - 2 * uInnerSpace Or MaxRowExtents > w - 2 * uInnerSpace Then
currentFontSize = currentFontSize - (dblCurDelta / 2) '0.25
CC.SelectFont uFontName, minFontSize + currentFontSize, 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, Not uSingleline, bOnlyOnLineBreaks, RowsCharCount, RowsCharOffset, RowCount, MaxRowExtents
' Calculate the total text height
textHeight = RowCount * CC.GetFontHeight
If uSingleline Then
Debug.Assert RowCount = 1
End If
End If
If Not uSingleline Then
' 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(Replace(s, vbCrLf, " "), " ")
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
CC.SelectFont uFontName, (minFontSize + currentFontSize) / MaxWExt * (w - 2 * uInnerSpace) * 0.92, uColor, uBold, uItalic, uUnderline
CC.CalcTextRowsInfo s, w - 2 * uInnerSpace, Not uSingleline, bOnlyOnLineBreaks, RowsCharCount, RowsCharOffset, RowCount, MaxRowExtents
textHeight = RowCount * CC.GetFontHeight ' Re-Calculate the total text height
End If
End If
If uMaxFontSize > 0 Then
Debug.Assert currentFontSize <= uMaxFontSize
End If
SetOptimalFSForTextRect = textHeight ' Return the last determined textHeight
End Function
Public Sub DrawTextEx(ByRef uMaxFontSize As Double, ByRef CC As cCairoContext, ByVal uText As String, ByVal uHAlign As AlignmentConstants, ByVal uVAlign As eVerticalAlignmentConstants, _
ByVal uLeft As Double, _
ByVal uTop As Double, _
ByVal uWidth As Double, _
ByVal uHeight As Double, _
ByVal uFontName As String, _
ByVal uColor As Long, _
ByVal uBold As Boolean, _
ByVal uItalic As Boolean, _
ByVal uUnderline As Boolean, _
ByVal uWithDropshadow As Boolean, _
ByVal uSingleline As Boolean)
Dim dblHeight As Double
dblHeight = SetOptimalFSForTextRect(uMaxFontSize, CC, uText, uWidth, uHeight, 0, uFontName, uColor, uBold, uItalic, uUnderline, uSingleline)
Dim dblYOffsetRed As Double
Dim dblYOffsetText As Double
If uVAlign = eVerticalAlignment_Olaf_Center Then
'no need to translate the rendering
dblYOffsetRed = (uHeight - dblHeight) / 2
dblYOffsetText = ((uHeight) / 2) - (dblHeight / 2)
ElseIf uVAlign = eVerticalAlignment_Olaf_Top Then
dblYOffsetRed = 0
dblYOffsetText = 0
ElseIf uVAlign = eVerticalAlignment_Bottom Then
dblYOffsetRed = uHeight - dblHeight
'The text rendering starts at the vertical middle of the surface
'and it is shifted vertically according to its height
'so the text drawing starts at surface/2
'- (textheight/2)
'if we want to align it on the bottom, we must do this:
'shift it so that it ends at the vertical middile:
dblYOffsetText = -(dblHeight / 2)
'and now add half the surface height
dblYOffsetText = dblYOffsetText + (uHeight / 2)
If dblYOffsetText > CC.Surface.Height Then
Debug.Assert False
End If
Else
Debug.Assert False
End If
'!!!!!!!! do not use the original vAlign!!!!
Dim lVAlign&
If uVAlign = eVerticalAlignment_Olaf_Center Then
lVAlign = 0 ' -1 ' 'VAlign - it (currently) supports only two "states" (Off == top-aligned == 0) and "On == v-centered for any value <> 0.
ElseIf uVAlign = eVerticalAlignment_Olaf_Top Then
lVAlign = 0 ' 'VAlign - it (currently) supports only two "states" (Off == top-aligned == 0) and "On == v-centered for any value <> 0.
ElseIf uVAlign = eVerticalAlignment_Bottom Then
'we need to calculate it ourselves
'so we use Olaf's top:
lVAlign = 0
End If
'VAlign - it (currently) supports only two "states" (Off == top-aligned == 0) and "On == v-centered for any value <> 0.
CC.Save 'buffer the context, since we use a translate in the line below
CC.TranslateDrawings 1, dblYOffsetText + 1
If uWithDropshadow Then
CC.Save
CC.SetLineCap CAIRO_LINE_CAP_ROUND
CC.SetLineJoin CAIRO_LINE_JOIN_ROUND
CC.SetLineWidth 1
CC.SetSourceColor uColor, 0.1 'make the font color transparent
CC.DrawText uLeft, uTop, uWidth, uHeight, uText, uSingleline, uHAlign, 0, lVAlign, dtNormal, 1, True
CC.SetLineWidth 3
CC.Stroke
CC.SetSourceColor uColor, 0.045
CC.DrawText uLeft, uTop, uWidth, uHeight, uText, uSingleline, uHAlign, 0, lVAlign, dtNormal, 1, True
CC.Fill
CC.Restore
End If
CC.DrawText uLeft, uLeft, uWidth, uHeight, uText, uSingleline, uHAlign, 0, lVAlign, dtNormal, 1 'der alphawert hat keinen einfluss auf setsourcecolor-alpha. es wird overrult! '0, 0, uText 'this is the final "on-top-Textout" which takes place in either case
CC.Restore
CC.Save 'buffer the context, since we use a translate in the line below
CC.TranslateDrawings 0, dblYOffsetRed
DrawRectangle CC, uLeft, uTop, uWidth - 2, uHeight - 2, 0, vbRed, 0.5, vbBlue, 0.8
CC.Restore
End Sub
Thank you!
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
I am really. It was a flaw in my code! All is good.
-
1 Attachment(s)
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
I have augmented the code by adding the single line option back in.
There is one situation where the text renders offscreen (left: < 0), and "MaxDxNeeded" is 0:
Dim lRet&
lRet = CC.DrawText(uLeft, uLeft, lEffectiveAvailableWidth, lEffectiveAvailableHeight, uText, uSingleline, uHAlign, 0, lVAlign, dtNormal, 1, , dblWidthNeeded)
Would anybody be willing to take a look where I made a math error?
I don't manage to resolve it. I would appreciate any help very much!
Thank you.
I have hardcoded the width and height in the sample project to show you the problem.
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Quote:
Originally Posted by
tmighty2
I have augmented the code by adding the single line option back in.
There is one situation where the text renders offscreen (left: < 0), and "MaxDxNeeded" is 0:
Dim lRet&
lRet = CC.DrawText(uLeft, uLeft, lEffectiveAvailableWidth, lEffectiveAvailableHeight, uText, uSingleline, uHAlign, 0, lVAlign, dtNormal, 1, , dblWidthNeeded)
Would anybody be willing to take a look where I made a math error?
I don't manage to resolve it. I would appreciate any help very much!
Thank you.
I have hardcoded the width and height in the sample project to show you the problem.
With your now "forced" SingleLine-behaviour via Parameter from the outside -
you can re-use an already existing codeblock in the function...
(the one which starts with the Words-Array-Split)
The only difference now in your "Words-Array" should be, that the Words-Array has only one Member, your whole String:
Code:
'If Not uSingleLine Then is not needed anymore...
Dim Words() As String
If uSingleline Then
ReDim Words(0 To 0)
Words(0) = Replace(s, vbCrLf, " ") ' Replace line breaks with spaces
Else
Words = Split(Replace(s, vbCrLf, " "), " ") 'split the string into individual words
End If
' Initialize the maximum width extent to zero
Dim dblMaxWExt As Double
dblMaxWExt = 0
' Loop through each word to determine the maximum extent
Dim i&
For i = 0 To UBound(Words)
' Get the text extent for the current word
Dim dblWExt As Double
dblWExt = CC.GetTextExtents(Words(i))
' Update the maximum width extent if the current word's extent is larger
If dblMaxWExt < dblWExt Then
dblMaxWExt = dblWExt
End If
Next
' Calculate the allowable width limit based on the inner space
Dim dblWidthLimit As Double
dblWidthLimit = w - 2 * uInnerSpace
' Check if the maximum width extent exceeds the allowed width
If dblMaxWExt > dblWidthLimit Then
' Adjust the font size based on the maximum width extent and width limit
' Calculate the sum of minimum and current font sizes
Dim dblFontSum As Double
dblFontSum = minFontSize + currentFontSize
' Calculate the ratio of font sum to the maximum word extent
Dim dblFontSizeRatio As Double
dblFontSizeRatio = dblFontSum / dblMaxWExt
' Calculate the adjusted width limit
Dim dblAdjustedWidthLimit As Double
dblAdjustedWidthLimit = dblWidthLimit * 0.92
' Calculate the adjusted font size based on the ratio and adjusted width limit
Dim dblAdjustedFontSize As Double
dblAdjustedFontSize = dblFontSizeRatio * dblAdjustedWidthLimit
' Apply the adjusted font size
CC.SelectFont uFontName, dblAdjustedFontSize, uColor, uBold, uItalic, uUnderline
' Recalculate the text rows information with the updated font size
CC.CalcTextRowsInfo s, dblWidthLimit, bMultiLine, bOnlyOnLineBreaks, RowsCharCount, RowsCharOffset, RowCount, MaxRowExtents
' Recalculate the total text height based on the row count and font height
textHeight = RowCount * CC.GetFontHeight
End If
If uMaxFontSize > 0 Then
Debug.Assert currentFontSize <= uMaxFontSize
End If
SetOptimalFSForTextRect = textHeight ' Return the last determined textHeight
End Function
Olaf
-
3 Attachment(s)
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Thank you.
I am still fighting with the math. There are situations where no text is drawn. I was not sure how to solve the MaxFontSize option.
It is possible that my atttempt to solve this problem caused more problems.
To be able to reproduce it, I have enhanced the demo, the project is attached. A quick explanation is shown below.
When I use the following values, no text is drawn:
Code:
lLeft = 0
lTop = 0
lWidth = 310
lHeight = 31
vAlign = 1
hAlign = 2
sFontName = Segoe UI
bBold = -1
bItalic = 0
bUnderline = 0
dblMaxFontSize = 24
bSingleLine = 0
bWithDropshadow = -1
sText = 15:41:38
SurfWidth = 310
SurfHeight = 31
This is one is another case where no text is drawn:
Code:
lLeft = 0
lTop = 0
lWidth = 810
lHeight = 274
vAlign = 2
hAlign = 1
sFontName = Tahoma
bBold = -1
bItalic = 0
bUnderline = 0
dblMaxFontSize = 54
bSingleLine = -1
bWithDropshadow = 0
sText = Probalisticity-Evaluation
SurfWidth = 810
SurfHeight = 274
-
2 Attachment(s)
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Edit:
I re-read what Olaf wrote.
I believe the fact that the text is not draw is because the text does not fit in the given rect, and Singeline is False.
I added the "auto fix" code to the project, and the text is now drawn.
However, the fact that the font size is not calculated correctly persists.
I believe that this is due to the maximum font size that I had to include and which I didn't manage to do right and efficiently.
Attachment 193385
Can somebody help?
Thank you.
These are the settings showing the flaw:
lLeft = 0
lTop = 0
lWidth = 467
lHeight = 23
vAlign = 0
hAlign = 2
sFontName = Tahoma
bBold = -1
bItalic = 0
bUnderline = 0
dblMaxFontSize = 138
bSingleLine = 0
bWithDropshadow = 0
sText = Probalisticity-Evaluation
SurfWidth = 467
SurfHeight = 23
This is the new version:
-
1 Attachment(s)
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
Edit: I have removed all the code that I thought was necessary additionally and implemented only what Olaf told me, and now it works.
Here is the (hopefully final project).
Thank you!
-
Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic
I have yet again a problem:
I don't know how to fix the situation in the line where I wrote the following comment:
'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.
Could anybody help?
Thank you very much!
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
' Set the initial font size and the adjustment delta
Dim currentFontSize As Double
currentFontSize = 64
If uMaxFontSize > 0 Then
currentFontSize = 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
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
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
Debug.Assert False
End If
uMaxFontSize = dblFontSize
SetOptimalFSForTextRect = textHeight ' Return the last determined textHeight
End Function
-
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!
-
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
