Confusing Chr$ explanation - Printable Version

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