Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Is _NEWIMAGE just a nicer way of saying, "Special needs?"
#11
Okay, I found one I like...

Code: (Select All)
Screen _NewImage(860, 300, 32)
_Delay .1
_ScreenMove _Middle
_Delay .1
nof = 4
ReDim fh(nof) As Long
fh(0) = _LoadFont("c:\windows\fonts\lucon.ttf", 16)
fh(1) = _LoadFont("RobotoMono-regular.ttf", 21, "monospace")
fh(2) = _LoadFont("RobotoMono-regular.ttf", 21)

For i = 0 To 2
    If fh(i) <= 0 Then
        Print "Failed to load font."
        End
    End If
Next

_PrintString (16, 21), " Test for a monospaced font. a and b will align if mono..."
_Font fh(1)
_PrintString (16, 21 * 3), "mmmmmmmmmmmmmmmmmmmma"
_Font fh(2)
Locate 4, 16
_PrintString (16, 21 * 4), "mmmmmmmmmmmmmmmmmmmmb"
_Font fh(0)

fh(0) = _LoadFont("c:\windows\fonts\lucon.ttf", 16)
fh(1) = _LoadFont("RobotoMono-regular.ttf", 21)
fh(2) = _LoadFont("RobotoMono-bold.ttf", 21)
fh(3) = _LoadFont("RobotoMono-italic.ttf", 21)
fh(4) = _LoadFont("RobotoMono-bolditalic.ttf", 21)

For i = 0 To nof
    If fh(i) <= 0 Then
        Print "Failed to load font."
        End
    End If
Next

Locate 9, 16: Print " Here's how they look...";

If print0 Then
    x = 16: y = 8: a = 0: k = 0
    For i = 1 To 26 * 4
        a = a + 1
        _Font fh(a)
        Locate y, x: Print Chr$(97 + k);
        x = x + 16
        If i = 26 * 2 Then y = y + 1: x = 16
        If i Mod 4 = 0 Then a = 0: k = k + 1
    Next
Else
    x = 15: y = 21 * 8
    For i = 1 To 26 * 4
        a = a + 1
        _Font fh(a)
        _PrintString (x, y), Chr$(97 + k)
        x = x + 16
        If i = 26 * 2 Then y = y + 21: x = 15
        If i Mod 4 = 0 Then a = 0: k = k + 1
    Next
End If

_Font fh(0)
End

What's interesting is the "monospace" handle is essentially useless if you try to use it with  non-monospaced font. Too many display problems, and forget about using the PRINT statement in graphics mode if you do try and go that way. It will throw the character positioning waaaaaay off. _PrintString works, but, again, the fonts will probably display poorly. My advice, stick with monospaced fonts or make a routine with _PrintWidth to improve the presentation of non-monospaced fonts if you are trying to preserve a fixed number of character spaces per line.

Pete


Attached Files
.zip   roboto-mono.zip (Size: 697.56 KB / Downloads: 16)
Reply
#12
Here is a font tester I made awhile ago, you might have missed it Pete:
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 Function

Like you say, monospace is useless if the font doesn't have that option, same for the other options like Bold or Italic.
b = b + ...
Reply
#13
FONTastic!

Yeah, the wiki really needs a bit of an update/rewrite. "UNDERLINE" what a load of BS that is. I bet that didn't work back in the QB64 1.0 days, either. Most fonts with underlined glyths only include vowels. I'm pretty convinced graphics or text-graphics hybrid will be required to include underling ability, where a simple statement can draw a thin line one  pixel below the bottom of the character base.

Although we can o the math to get non-monospace fonts to wrap properly, that work gets stomped upon when we implement the bold and italicized fonts. Of course the math could fix that, as well, but it would require working out an algorithm with _PRINTWIDTH so that each font character would display reasonably well spaced in any of the regular, bold, and italicized mixes.

Maybe I can get Bill to give up his old show and host "Fun with Fonts" instead.

Pete
Reply




Users browsing this thread: 1 Guest(s)