This might be of help in your investulation (sic): (my first use of _Uprint stuff along side standard _print string)
Try Gabriola.ttf 24 Monospace. With _Printstring it's a mess but with _Uprint...
Complete makeover success story for _Uprint stuff!
Code: (Select All)
_Title "Font Tester 2" ' 2023-05-27 b+ makeover
' From looking at: fancy-font-names.bas by mnrvovrfc 27-May-2023
' Starting with a more complete list of 136 font names in FontList.txt file to select from
' THEN choose pixel size and style
' THEN if that set works you can see a demo sample else try again until escape
' Font Tester 2 lets just see how much _UprintString can improve the look of fonts.
' Also dump all the Style choices either "MONOSPACE" or nuttin
Option _Explicit
Const SW& = 1024, SH& = 600 ' our screen dimensions
Screen _NewImage(SW, SH, 32) ' get our screen up
_ScreenMove 150, 50 ' center it on laptop size screen
Dim fLine$ ' file line
Dim As Long i, j ' general indexs
'check if our file is already done
If _FileExists("FontList.txt") = 0 Then ' nope make it
Shell _Hide "DIR C:\Windows\Fonts\*.ttf /b > FontList.txt" ' file is made
End If
Dim maxLine As Long ' count file lines for number of font names
Open "FontList.txt" For Input As #1
While EOF(1) = 0
maxLine = maxLine + 1
Line Input #1, fLine$
Wend
Close
Dim Shared fontNames$(1 To maxLine) ' setup and load array
Open "FontList.txt" For Input As #1
For i = 1 To maxLine
Line Input #1, fontNames$(i)
Next
Close ' names are loadedinto array
' now to get our font specs for font name, height and style
Dim NameSelected$ ' select a font name to try
Dim pixelHeight$ ' input a pixel height for font
Dim As Long ph ' pixelHeight converted to number type
Dim style$ ' Style type to test
Dim As Long FH ' font handle we are about to sample
Dim sample$(0 To 11) ' display sampler of most characters in font, size and style
sample$(0) = ""
sample$(1) = " Font name: "
sample$(2) = "Pixel Height:"
sample$(3) = " Style: "
sample$(4) = ""
sample$(5) = " Sample:"
sample$(6) = "AaBbCcDdEeFfGgHh"
sample$(7) = "IiJjKkLlMmOoPpQq"
sample$(8) = "RrSsTtUuVvWwXxYy"
sample$(9) = "Zz 0123456789 !@"
sample$(10) = "#$%^&*() _+-= :;"
sample$(11) = "<>?/.,"
Dim YesNo ' this is for user reply if they want to quit
'----------------------------------------------------------------------------------------
Dim Fonthandle& ' this for testing Clipboard by pasting in results see below some samples
' test pastes from Clipboard Ubderline doesn't work nor Italic unless font is already
Fonthandle& = _LoadFont("arial.ttf", 24, "")
Fonthandle& = _LoadFont("comicz.ttf", 24, "MONOSPACE")
Fonthandle& = _LoadFont("consola.ttf", 64, "ITALIC") ' no italic
Fonthandle& = _LoadFont("georgiab.ttf", 40, "BOLD")
'-----------------------------------------------------------------------------------------
Do Until _KeyDown(27)
_Font 16
restart: ' get a font name
Cls
Locate 4, 20: Print "FontList names to select from:"
NameSelected$ = GetArrayItem$(6, 10, 100, 30, fontNames$())
If NameSelected$ = "" Then GoTo CheckQuit Else Locate 1, 10: Print "Font name: "; NameSelected$
getph: ' spec a height
pixelHeight$ = _InputBox$("Specify Pixel Height for font", "Enter something between 8 and 64.")
If pixelHeight$ = "" GoTo CheckQuit
ph = Val(pixelHeight$)
If ph < 8 Or ph > 64 Then
Beep: GoTo getph
Else
Locate 2, 10: Print "Pixel Height:"; ph
End If
getStyle: ' spec a style though I think None or Monospace are only ones that work
YesNo = _MessageBox("MONOSPACE?", "Do you want MonoSpace for same char widths in text?", "yesno", "question")
If YesNo = 1 Then style$ = "MONOSPACE" Else style$ = ""
Locate 3, 10: Print "Style:"; style$
' OK now setting up for display of sample
If FH Then _FreeFont FH ' clear old fh load new
FH = _LoadFont(NameSelected$, ph, style$) ' whatsa common size
Cls
If FH Then
_Font FH
For j = 1 To 2
Cls
'Print "Old Style Print with Font:" '0
'Print " Font name: "; NameSelected$ ' 1
'Print "Pixel Height:"; ph ' 2
'Print " Style: "; style$ ' 3
'Print
For i = 0 To 11
If j = 1 Then
If i = 0 Then
Print "Old Print of Font:"
ElseIf i = 1 Then
Print sample$(1) + NameSelected$
ElseIf i = 2 Then
Print sample$(2) + Str$(ph)
ElseIf i = 3 Then
Print sample$(3) + style$
ElseIf i > 3 And i <= 10 Then
Print sample$(i)
ElseIf i = 11 Then
Print sample$(i)
' this stops execution until a click as good as sleep!
_MessageBox "Font Test;", "The font name, height, style: " + Chr$(10) + Chr$(34) +_
NameSelected$ + Chr$(34) + "," + Str$(ph) + ", " + Chr$(34) + style$ + Chr$(34)
End If
ElseIf j = 2 Then
If i = 0 Then
_UPrintString (0, 0), "_UPrintString of Font:"
ElseIf i = 1 Then
_UPrintString (0, i * _ULineSpacing(FH)), sample$(1) + NameSelected$
ElseIf i = 2 Then
_UPrintString (0, i * _ULineSpacing(FH)), sample$(2) + Str$(ph)
ElseIf i = 3 Then
_UPrintString (0, i * _ULineSpacing(FH)), sample$(3) + style$
ElseIf i > 3 And i <= 10 Then
_UPrintString (0, i * _ULineSpacing(FH)), sample$(i)
ElseIf i = 11 Then
_UPrintString (0, i * _ULineSpacing(FH)), sample$(i)
' this stops execution until a click as good as sleep!
_MessageBox "Font Test;", "The font name, height, style: " + Chr$(10) + Chr$(34) +_
NameSelected$ + Chr$(34) + "," + Str$(ph) + ", " + Chr$(34) + style$ + Chr$(34)
End If
End If
Next
Next
' as mnrvovrfc has conveniently done, load our choices into Clipboard
_Clipboard$ = "FontHandle& = _LoadFont(" + Chr$(34) + NameSelected$ + Chr$(34)+_
","+ Str$(ph) + ", " + Chr$(34) + style$ + Chr$(34)+ ")"
Else
_MessageBox "Font Test", "The font did not load, try again or escape quits."
End If
Loop
System
CheckQuit:
YesNo = _MessageBox("Quit?", "Do you wish to quit?", "yesno", "question")
If YesNo = 1 Then End Else GoTo restart
' ==================================================================== from my toolbox
' for saving and restoring screen settins
Sub ScnState (restoreTF As Long) 'Thanks Steve McNeill
Static defaultColor~&, backGroundColor~&
Static font&, dest&, source&, row&, col&, autodisplay&, mb&
If restoreTF Then
_Font font&
Color defaultColor~&, backGroundColor~&
_Dest dest&
_Source source&
Locate row&, col&
If autodisplay& Then _AutoDisplay Else _Display
_KeyClear
While _MouseInput: Wend 'clear mouse clicks
mb& = _MouseButton(1)
If mb& Then
Do
While _MouseInput: Wend
mb& = _MouseButton(1)
_Limit 100
Loop Until mb& = 0
End If
Else
font& = _Font: defaultColor~& = _DefaultColor: backGroundColor~& = _BackgroundColor
dest& = _Dest: source& = _Source
row& = CsrLin: col& = Pos(0): autodisplay& = _AutoDisplay
_KeyClear
End If
End Sub
' Help: all this I hope is intuitive so Help not needed
' "Mouse, mouse wheel, and arrow keys should work as expected for item selection."
' "Press spacebar to select a highlighted item or just click it."
' "Use number(s) + enter to select an array item by it's index number,"
' "backspace will remove last number pressed, c will clear a number started. << Change to Delete
' "Numbers started are shown in bottom right PgDn bar."
' "Enter will also select the highlighted item, if no number has been started."
' "Home starts you at lowest array index, End highlights then highest index."
' "Use PgUp and PgDn keys to flip through pages of array items."
'
' Escape to Cancel Return "" else Return the selected string from the array
' 2023-05-27 mod added choice to get array index returned
Function GetArrayItem$ (locateRow, locateColumn, boxWidth, boxHeight, arr() As String)
'This sub needs ScrState to store and restore screen condition before and after this sub does it's thing
'Notes: locateRow, locateColumn for top right corner of selection box on screen in characters for LOCATE.
'boxWidth and boxHeight are in character units, again for locate and print at correct places.
'All displaying is restricted to inside the box, which has PgUP and PgDn as top and bottom lines in the display.
Dim maxWidth As Integer, maxHeight As Integer, page As Integer, hlite As Integer, mx As Integer, my As Integer
Dim lastMX As Integer, lastMY As Integer, row As Integer, mb As Integer
Dim lba As Long, uba As Long, kh As Long, index As Long, choice As Long
Dim clrStr As String, b As String
'save old settings to restore at end ofsub
ScnState 0
maxWidth = boxWidth ' number of characters in box
maxHeight = boxHeight - 2 ' number of lines displayed of array at one time = 1 page
lba = LBound(arr)
uba = UBound(arr)
page = 0
hlite = 0 ' line in display ready for selection by spacebar or if no number is started, enter
clrStr$ = Space$(maxWidth) 'clearing a display line
GoSub update ' show the beginning of the array items for selection
choice = -1719
Do 'until get a selection or demand exit
'handle the key stuff
kh& = _KeyHit
If kh& Then
If kh& > 0 And kh& < 255 Then
If InStr("0123456789", Chr$(kh&)) > 0 Then b$ = b$ + Chr$(kh&): GoSub update
If Chr$(kh&) = "c" Then b$ = "": GoSub update
If kh& = 13 Then 'enter pressed check if number is being entered?
If Len(b$) Then
If Val(b$) >= lba And Val(b$) <= uba Then 'we have number started
choice = Val(b$): Exit Do
Else 'clear b$ to show some response to enter
b$ = "": GoSub update 'clear the value that doesn't work
End If
Else
choice = hlite + page * maxHeight + lba 'must mean to select the highlighted item
End If
End If
If kh& = 27 Then Exit Do 'escape clause offered to Cancel selection process
If kh& = 32 Then choice = hlite + page * maxHeight + lba 'best way to choose highlighted selection
If kh& = 8 Then 'backspace to edit number
If Len(b$) Then b$ = Left$(b$, Len(b$) - 1): GoSub update
End If
Else
Select Case kh& 'choosing sections of array to display and highlighted item
Case 20736 'pg dn
If (page + 1) * maxHeight + lba <= uba Then page = page + 1: GoSub update
Case 18688 'pg up
If (page - 1) * maxHeight + lba >= lba Then page = page - 1: GoSub update
Case 18432 'up
If hlite - 1 < 0 Then
If page > 0 Then
page = page - 1: hlite = maxHeight - 1: GoSub update
End If
Else
hlite = hlite - 1: GoSub update
End If
Case 20480 'down
If (hlite + 1) + page * maxHeight + lba <= uba Then 'ok to move up
If hlite + 1 > maxHeight - 1 Then
page = page + 1: hlite = 0: GoSub update
Else
hlite = hlite + 1: GoSub update
End If
End If
Case 18176 'home
page = 0: hlite = 0: GoSub update
Case 20224 ' end
page = Int((uba - lba) / maxHeight): hlite = maxHeight - 1: GoSub update
End Select
End If
End If
'handle the mouse stuff
While _MouseInput
If _MouseWheel = -1 Then 'up?
If hlite - 1 < 0 Then
If page > 0 Then
page = page - 1: hlite = maxHeight - 1: GoSub update
End If
Else
hlite = hlite - 1: GoSub update
End If
ElseIf _MouseWheel = 1 Then 'down?
If (hlite + 1) + page * maxHeight + lba <= uba Then 'ok to move up
If hlite + 1 > maxHeight - 1 Then
page = page + 1: hlite = 0: GoSub update
Else
hlite = hlite + 1: GoSub update
End If
End If
End If
Wend
mx = Int((_MouseX - locateColumn * 8) / 8) + 2: my = Int((_MouseY - locateRow * 16) / 16) + 2
If _MouseButton(1) Then 'click contols or select array item
'clear mouse clicks
mb = _MouseButton(1)
If mb Then 'clear it
While mb 'OK!
If _MouseInput Then mb = _MouseButton(1)
_Limit 100
Wend
End If
If mx >= 1 And mx <= maxWidth And my >= 1 And my <= maxHeight Then
choice = my + page * maxHeight + lba - 1 'select item clicked
ElseIf mx >= 1 And mx <= maxWidth And my = 0 Then 'page up or exit
If my = 0 And (mx <= maxWidth And mx >= maxWidth - 2) Then 'exit sign
Exit Do 'escape plan for mouse click top right corner of display box
Else 'PgUp bar clicked
If (page - 1) * maxHeight + lba >= lba Then page = page - 1: GoSub update
End If
ElseIf mx >= 1 And mx <= maxWidth And my = maxHeight + 1 Then 'page down bar clicked
If (page + 1) * maxHeight + lba <= uba Then page = page + 1: GoSub update
End If
Else ' mouse over highlighting, only if mouse has moved!
If mx >= 1 And mx <= maxWidth And my >= 1 And my <= maxHeight Then
If mx <> lastMX Or my <> lastMY Then
If my - 1 <> hlite And (my - 1 + page * maxHeight + lba <= uba) Then
hlite = my - 1
lastMX = mx: lastMY = my
GoSub update
End If
End If
End If
End If
_Limit 200
Loop Until choice >= lba And choice <= uba
If choice <> -1719 Then GetArrayItem$ = arr(choice) 'set function and restore screen
ScnState -1 'restore
Exit Function
'display of array sections and controls on screen ====================================================
update:
'fix hlite if it has dropped below last array item
While hlite + page * maxHeight + lba > uba
hlite = hlite - 1
Wend
'main display of array items at page * maxHeight (lines high)
For row = 0 To maxHeight - 1
If hlite = row Then Color _RGB32(200, 200, 255), _RGB32(0, 0, 88) Else Color _RGB32(0, 0, 88), _RGB32(200, 200, 255)
Locate locateRow + row, locateColumn: Print clrStr$
index = row + page * maxHeight + lba
If index >= lba And index <= uba Then
Locate locateRow + row, locateColumn
Print Left$(LTrim$(Str$(index)) + ") " + arr(index), maxWidth)
End If
Next
'make page up and down bars to click, print PgUp / PgDn if available
Color _RGB32(200, 200, 255), _RGB32(0, 100, 50)
Locate locateRow - 1, locateColumn: Print Space$(maxWidth)
If page <> 0 Then Locate locateRow - 1, locateColumn: Print Left$(" Pg Up" + Space$(maxWidth), maxWidth)
Locate locateRow + maxHeight, locateColumn: Print Space$(maxWidth)
If page <> Int(uba / maxHeight) Then
Locate locateRow + maxHeight, locateColumn: Print Left$(" Pg Dn" + Space$(maxWidth), maxWidth)
End If
'make exit sign for mouse click
Color _RGB32(255, 255, 255), _RGB32(200, 100, 0)
Locate locateRow - 1, locateColumn + maxWidth - 3
Print " X "
'if a number selection has been started show it's build = b$
If Len(b$) Then
Color _RGB32(255, 255, 0), _RGB32(0, 0, 0)
Locate locateRow + maxHeight, locateColumn + maxWidth - Len(b$) - 1
Print b$;
End If
_Display
_Limit 100
Return
End FunctionTry Gabriola.ttf 24 Monospace. With _Printstring it's a mess but with _Uprint...
Complete makeover success story for _Uprint stuff!
b = b + ...