Results 1 to 39 of 39

Thread: RC6 cCairoSurface: Implementing a "biggest font size available" logic

  1. #1

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    Question 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

  2. #2
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,416

    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

  3. #3

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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.
    Last edited by tmighty2; Sep 3rd, 2024 at 05:00 PM.

  4. #4

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic

    Here is a new version of the project.
    Attached Files Attached Files

  5. #5
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,416

    Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic

    Quote Originally Posted by tmighty2 View Post
    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

  6. #6

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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.

  7. #7

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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.
    Last edited by tmighty2; Sep 17th, 2024 at 11:46 PM.

  8. #8

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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...
    Name:  fonttop.jpg
Views: 354
Size:  28.4 KB
    Attached Files Attached Files
    Last edited by tmighty2; Sep 18th, 2024 at 12:27 AM.

  9. #9

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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.
    Last edited by tmighty2; Sep 18th, 2024 at 02:04 AM.

  10. #10
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,416

    Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic

    Quote Originally Posted by tmighty2 View Post
    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 View Post
    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

  11. #11

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic

    Can you please tell me how to avoid line breaks within words like these?

    Name:  break1.png
Views: 331
Size:  7.6 KB

    I have attached the current version of the project.

    Thank you!
    Attached Files Attached Files

  12. #12

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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.
    Last edited by tmighty2; Sep 23rd, 2024 at 10:01 AM.

  13. #13
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,416

    Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic

    Quote Originally Posted by tmighty2 View Post
    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

  14. #14

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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.
    Attached Images Attached Images  
    Last edited by tmighty2; Sep 23rd, 2024 at 11:03 AM.

  15. #15
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,416

    Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic

    Quote Originally Posted by tmighty2 View Post
    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

  16. #16

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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:
    Attached Images Attached Images  
    Last edited by tmighty2; Sep 23rd, 2024 at 02:20 PM.

  17. #17
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,416

    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

  18. #18

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic

    Thank you!

  19. #19

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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.
    Last edited by tmighty2; Oct 10th, 2024 at 07:05 PM.

  20. #20

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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...)

  21. #21
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,416

    Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic

    Quote Originally Posted by tmighty2 View Post
    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 View Post
    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

  22. #22

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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.
    Attached Files Attached Files
    Last edited by tmighty2; Oct 18th, 2024 at 04:32 AM.

  23. #23

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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!

    Name:  2 green arrows.png
Views: 134
Size:  15.5 KB
    Last edited by tmighty2; Oct 18th, 2024 at 07:23 AM.

  24. #24
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,416

    Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic

    Quote Originally Posted by tmighty2 View Post
    I notice a gap in some situations.
    Please enhance the simplified word-splitter-codeline this way:

    Words = Split(Replace(s, vbCrLf, " "), " ")

    Olaf

  25. #25

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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.
    Attached Files Attached Files

  26. #26
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,416

    Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic

    Quote Originally Posted by tmighty2 View Post
    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

  27. #27

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic

    You are really most helpful. Thank you!

  28. #28

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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.
    Name:  not visible when centered.jpg
Views: 123
Size:  27.3 KB
    Attachment 193168
    Attached Files Attached Files
    Last edited by tmighty2; Oct 18th, 2024 at 05:20 PM.

  29. #29

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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
    Attached Files Attached Files
    Last edited by tmighty2; Oct 31st, 2024 at 03:35 PM.

  30. #30
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,416

    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

  31. #31
    PowerPoster
    Join Date
    Jan 2020
    Posts
    4,480

    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.

  32. #32

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic

    ----
    Last edited by tmighty2; Oct 31st, 2024 at 03:36 PM.

  33. #33

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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!
    Attached Files Attached Files
    Last edited by tmighty2; Oct 31st, 2024 at 03:36 PM.

  34. #34

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic

    I am really. It was a flaw in my code! All is good.

  35. #35

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    Question 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.
    Attached Files Attached Files
    Last edited by tmighty2; Nov 2nd, 2024 at 04:51 PM.

  36. #36
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,416

    Re: RC6 cCairoSurface: Implementing a "biggest font size available" logic

    Quote Originally Posted by tmighty2 View Post
    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

  37. #37

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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
    Attached Images Attached Images  
    Attached Files Attached Files
    Last edited by tmighty2; Nov 3rd, 2024 at 10:57 AM.

  38. #38

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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.

    Name:  flaw.png
Views: 37
Size:  5.2 KB

    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:
    Attached Files Attached Files

  39. #39

    Thread Starter
    Fanatic Member
    Join Date
    Jul 2017
    Posts
    580

    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!
    Attached Files Attached Files
    Last edited by tmighty2; Nov 4th, 2024 at 04:24 AM.

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
  •  



Click Here to Expand Forum to Full Width