Posts: 1,586
Threads: 59
Joined: Jul 2022
Reputation:
52
05-27-2023, 08:28 AM
(This post was last modified: 05-27-2023, 08:38 AM by mnrvovrfc.
Edit Reason: Added screenshot
)
This is a program that interacts with the user, asking him/her what is the "fancy" font name, and then it shows a dialog indicating what is the QB64 code line to use to load that font. The QB64 code line is copied to the clipboard so it could be pasted right away into the QB64 IDE.
It requires a text file called "fancy-font-names.txt" in the same directory as the executable.
This program was tested on Linux (Manjaro MATE) but with the provided text file it should work on Windows. I have listed only the fonts actually installed by "winetricks corefonts" by Debian v11 "Bullseye". I added one more, for Lucida Console which is not installed for Wine.
It's easy to add more fonts to the text file. Each line should have two fields separated by semicolon. In the first field enter the font name you wish to use. The second field is the full path of the filename of the font. Note that Bold, Italic, Semicondensed etc. are on separate TTF files than the "Regular" version and will be called differently.
It should be easier than ever to pull a text-file directory listing on Windows. Use
Code: (Select All) dir /b/s C:\Windows\Fonts
the last time I checked. It has to be redirected to a text file, to then add the fancy names ending with semicolon at the front of each line. Tedious task, I know, but I did most of the work for you for the most common fonts.
The code is being shown here, but please download the ZIP attachment with this post.
Code: (Select All) 'by mnrvovrfc 27-May-2023
OPTION _EXPLICIT
$SCREENHIDE
TYPE twostring
fancy AS STRING * 64
apath AS STRING * 192
END TYPE
DIM infile$, oneline$, entry$, oldentry$
DIM AS LONG ff, sfl, i, u, lentry, choice
REDIM sf(1 TO 1) AS twostring
infile$ = "fancy-font-names.txt"
IF NOT _FILEEXISTS(infile$) THEN
_MESSAGEBOX "File not found", "I'm sorry, but the required file wasn't found." + CHR$(13) + infile$, "info"
SYSTEM
END IF
ff = FREEFILE
OPEN infile$ FOR INPUT AS ff
DO UNTIL EOF(ff)
LINE INPUT #ff, oneline$
u = INSTR(oneline$, ";")
IF u > 0 THEN
sfl = sfl + 1
REDIM _PRESERVE sf(1 TO sfl) AS twostring
sf(sfl).fancy = LEFT$(oneline$, u - 1)
sf(sfl).apath = MID$(oneline$, u + 1)
END IF
LOOP
CLOSE ff
entry$ = _INPUTBOX$("Fancy Font Names", "What is the fancy name of the font you'd like?", " ")
IF entry$ = "" THEN SYSTEM
oldentry$ = entry$
entry$ = LCASE$(entry$)
lentry = LEN(entry$)
choice = 0
oneline$ = ""
FOR i = 1 TO sfl
oneline$ = LEFT$(LCASE$(RTRIM$(sf(i).fancy)), lentry)
IF oneline$ = entry$ THEN choice = i: EXIT FOR
NEXT
IF choice THEN
_MESSAGEBOX "Fancy Font Names", "The QB64 statement to load" + CHR$(13) + oldentry$ + " is " + chr$(34) +_
"fonthandle = _LOADFONT(" + chr$(34) +rtrim$(sf(choice).apath) + chr$(34) + ", pointsize)" + chr$(13) +_
"Be sure to set the " + chr$(34) + "pointsize" + chr$(34) +"as an integer from 8 to 128." + chr$(13) +_
"The QB64 code line was copied to the clipboard.", "info"
_CLIPBOARD$ = "fonthandle = _LOADFONT(" + CHR$(34) + RTRIM$(sf(choice).apath) + CHR$(34) + ", pointsize)"
ELSE
_MESSAGEBOX "Font name not found", "I'm sorry, I was unable to find the filename for the fancy font you entered:" +_
CHR$(13) + oldentry$, "info"
END IF
SYSTEM
fancy-font-names.zip (Size: 1.48 KB / Downloads: 62)
![[Image: fancy-font-dialogs.png]](https://i.ibb.co/X4TDS5w/fancy-font-dialogs.png)
Posts: 3,980
Threads: 177
Joined: Apr 2022
Reputation:
220
05-28-2023, 02:11 AM
(This post was last modified: 05-28-2023, 02:14 AM by bplus.)
Well I like the idea of this so much, I improved it for my Windows use:
Code: (Select All) _Title "Font tester" ' 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
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 i As Long ' general index
'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 As Long styleN ' style Number from menu
Dim style$ ' Style type to test
Dim As Long FH ' font handle we are about to sample
Dim StyleMenu$ ' long string to appear as Menu to select a style number from
StyleMenu$ = "1 for none" + Chr$(10) + "2 for MONOSPACE" + Chr$(10) + "3 for BOLD" + Chr$(10) +_
"4 for ITALIC" + Chr$(10) + "5 for UNDERLINE"
Dim sample$ ' display sampler of most characters in font, size and style
sample$ = " Sample:" + Chr$(10) + _
"AaBbCcDdEeFfGgHh" + chr$(10) + _
"IiJjKkLlMmOoPpQq" + chr$(10) + _
"RrSsTtUuVvWwXxYy" + chr$(10) + _
"Zz 0123456789 !@" + chr$(10) + _
"#$%^&*() _+-= :;" + chr$(10) + _
"<>?/.,"
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
style$ = _InputBox$("Enter style number:", StyleMenu$)
If style$ = "" GoTo CheckQuit Else styleN = Val(style$)
If styleN < 1 Or styleN > 5 Then Beep: GoTo getStyle
Select Case styleN
Case 1: style$ = ""
Case 2: style$ = "MONOSPACE"
Case 3: style$ = "BOLD"
Case 4: style$ = "ITALIC"
Case 5: style$ = "UNDERLINE"
End Select
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
Cls
Print " Font name: "; NameSelected$
Print "Pixel Height:"; ph
Print " Style: "; style$
Print
Print sample$
_MessageBox "Font Test;", "The font name, height, style: " + Chr$(10) + Chr$(34) +_
NameSelected$ + Chr$(34) + "," + Str$(ph) + ", " + Chr$(34) + style$ + Chr$(34)
' 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
I also found a font I like 
clipboard "Fonthandle& = _LoadFont("georgiab.ttf", 40, "BOLD")"
Maybe @mnrvovrfc can adapt to Linux?
Meanwhile I will be adapting this to _U+printing of pe v3.7
b = b + ...
Posts: 2,698
Threads: 327
Joined: Apr 2022
Reputation:
217
@bplus Instead of Print, swap over to _UPrintString and you can avoid the letter clipping that you see in your screenshot above. (Look at the g on that first line.)
Posts: 3,980
Threads: 177
Joined: Apr 2022
Reputation:
220
(05-28-2023, 02:51 AM)SMcNeill Wrote: @bplus Instead of Print, swap over to _UPrintString and you can avoid the letter clipping that you see in your screenshot above. (Look at the g on that first line.)
bplus:
Quote:Meanwhile I will be adapting this to _U+printing of pe v3.7
I saw the g, you should see some of the other ugly things... one of the capital C font names I think... y i k e s!!!
b = b + ...
Posts: 1,586
Threads: 59
Joined: Jul 2022
Reputation:
52
Nice work bplus.
I created my program more along a question by PhilofPerth in your thread:
https://qb64phoenix.com/forum/showthread...6#pid16106
I guess a list of filenames could be acquired. However for my program it will require a "fancy" name which is what the topic is about. For the large number of TTF fonts, the fancy name could be surmised out of the filename.
Code: (Select All) cour.ttf -- REGULAR Courier.
couri.ttf -- ITALIC Courier.
^
courbd.txt -- BOLD Courier.
^^
courbi.ttf -- BOLD ITALIC Courier.
^^
Note that "Bold" is usually indicated by two letters, not one like with "Italic". A few fonts have "z" instead of "bi", and sport other styles like "Condensed", and "Italic" could be called "Oblique" instead. I discovered an "Arial Black" which name is "ariblk.ttf".
Font names for Linux are different, and the way they are organized. A "family" has its own directory such as "Liberation" and "Noto", and the font name and style is usually clearly spelled out.
Admittedly, my program was meant to work as simply as possible, and the user could choose whatever name he/she wanted such as "Best" instead of "Times New Roman" to point to "C:\Windows\Fonts\times.ttf". But there's no provision for the point size, although once pasted into the source code it could be quickly changed.
Posts: 3,980
Threads: 177
Joined: Apr 2022
Reputation:
220
05-28-2023, 01:20 PM
(This post was last modified: 05-28-2023, 01:21 PM by bplus.)
Right! It appears the only Style choices are none or MONOSPACE (does it really have to be all caps? well we could experiment...)
But I found such a nice way to insert a menu into an _InputBox$
Well when I adapt to _U+printing I will skip all the style stuff with a YesNo to MONOSPACE as you (mnrvovrfc, almost have it memorized finally! ) did.
b = b + ...
Posts: 3,980
Threads: 177
Joined: Apr 2022
Reputation:
220
Finally got around to modifying Font Tester to try and compare Old Print Method Font Display and New _UPrintString method:
Font Tester2:
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
Candara.ttf 32 was definitely improved by the New _UPrintString Method
Old Print:
New _UPrintString:
Georgiab.ttf 40 had slightly improved little g but still flat cut remains:
I don't know my eyes are getting too blurry to see anything at moment...
Some of the fonts not improved by the _UPrintString Method are improved using the MonoSpace Style:
2 Examples are (big difference):
bahshrift.ttf
calibri/ttf
So maybe some fonts are meant to be used as MonoSpace and not intended for no Style?
b = b + ...
Posts: 2,698
Threads: 327
Joined: Apr 2022
Reputation:
217
Was a few minor issues with blending, spacing, and such with UPrintString. Those have been addressed in the repo and can be tested via the development build or when 3.8+ releases.
Posts: 3,980
Threads: 177
Joined: Apr 2022
Reputation:
220
OK thanks to Rho Sigma and Steve for breaking down steps into pictures I got the most recent 3.7 development version to test "Font Tester2.bas" with, see https://qb64phoenix.com/forum/showthread.php?tid=1708
for details.
Now I am just looking at bahnschrift.ttf I remembered I had trouble with by both display methods:
3.7.0 Stable Old Print method:
Yuck!
3.7.0 stable _UPrintString method:
Still yuck
3.7.Dev latest as of 5/29 last mod a week before
And it's fixed for regular Old Print Method, the New _UPrintString Method is about the same except lines are spaced a little more for easier reading.
So 3.7.Dev has fixed things even with the Old Print method of Display. Nice work to dev team!
b = b + ...
|
