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