Posts: 9
Threads: 3
Joined: May 2022
Reputation:
1
I have about 750 true type fonts on my computer. Thus I needed some way to display them before I commit a program to using a particular font. So I wrote a simple program to display all the ascii characters and the upper and lower case alphabet. For this program it starts asking the name of the .ttf font. One would just type in 'arial' and it will fill in the .ttf. It then goes to a 1200x800 screen and displays the characters. At the end it asks for another font to display.
John
Code: (Select All)
top:
Input "font name: "; ttfont$
handle& = _NewImage(1200, 800, 32)
Screen handle&
_Title "Font Display: " + ttfont$
'ttfont$ = "courbd"
$Color:32
colorx
Color Black, LightBlue
Cls
height& = 20
fnt& = _LoadFont("./" + ttfont$ + ".ttf", height&, style$)
_Font fnt&
TextSize wide&, high& 'get the font or current screen mode's text block pixel size
For i = 1 To 255
If i > 8 And i < 14 Then Print i; "NA",: GoTo x 'these cause screen problems (linefeed, carriage return)
Print i; Chr$(i);
Print " ",
x:
If i / 10 = Int(i / 10) Then Print
Next
Print " "
Print " "
Print "abcdefghijklmnopqrstuvwxyz"
Print UCase$("abcdefghijklmnopqrstuvwxyz")
Print
GoTo top
End
Sub TextSize (TextWidth&, TextHeight&)
TextWidth& = _PrintWidth("W") 'measure width of one font or text character
TextHeight& = _FontHeight 'can measure normal text block heights also
End Sub
Sub colorx
Cls
Color Black, DarkCyan
End Sub
Posts: 88
Threads: 3
Joined: Apr 2022
Reputation:
17
03-03-2025, 04:53 PM
(This post was last modified: 03-03-2025, 05:02 PM by Steffan-68.)
(03-03-2025, 02:44 PM)Helium5793 Wrote: I have about 750 true type fonts on my computer. Thus I needed some way to display them before I commit a program to using a particular font. So I wrote a simple program to display all the ascii characters and the upper and lower case alphabet. For this program it starts asking the name of the .ttf font. One would just type in 'arial' and it will fill in the .ttf. It then goes to a 1200x800 screen and displays the characters. At the end it asks for another font to display.
John
Not bad what you did there. I like it.
I just changed it so that I don't always have to enter the name of the font.
Code: (Select All)
handle& = _NewImage(1200, 800, 32)
Screen handle&
$Color:32
colorx
Color Black, LightBlue
Cls
top:
ttfont$ = _OpenFileDialog$("Font Öffnen", "", "*.ttf", "Fontdatei", 0)
If ttfont$ = "" Then End
'Input "font name: "; ttfont$
_Title "Font Display: " + ttfont$
'ttfont$ = "courbd"
Cls
height& = 20
fnt& = _LoadFont(ttfont$, height&, style$)
_Font fnt&
TextSize wide&, high& 'get the font or current screen mode's text block pixel size
For i = 1 To 255
If i > 8 And i < 14 Then Print i; "NA",: GoTo x 'these cause screen problems (linefeed, carriage return)
Print i; Chr$(i);
Print " ",
x:
If i / 10 = Int(i / 10) Then Print
Next
Print " "
Print " "
Print "abcdefghijklmnopqrstuvwxyz"
Print UCase$("abcdefghijklmnopqrstuvwxyz")
Print
Sleep
_Font 8
_FreeFont fnt&
GoTo top
End
Sub TextSize (TextWidth&, TextHeight&)
TextWidth& = _PrintWidth("W") 'measure width of one font or text character
TextHeight& = _FontHeight 'can measure normal text block heights also
End Sub
Sub colorx
Cls
Color Black, DarkCyan
End Sub
Posts: 4,129
Threads: 189
Joined: Apr 2022
Reputation:
248
03-03-2025, 05:49 PM
(This post was last modified: 03-03-2025, 05:50 PM by bplus.)
Oh yeah, I have a little font tester 2 (Windows Only as I recall):
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
b = b + ...
Posts: 88
Threads: 3
Joined: Apr 2022
Reputation:
17
I also found something that I also liked very much.
I just don't know who wrote it, but it is definitely not from me.
Code: (Select All)
$Color:32
Type Font_type
name As String
dir As String
End Type
Type Color_Type
name As String
kolor As _Unsigned Long
End Type
_Icon
Screen _NewImage(800, 600, 32)
_Title "Text Previewer"
ReDim As Font_type Font(0)
ReDim Shared As Color_Type Kolor(0)
ReDim Shared As Font_type DefaultFont
Dim Shared As _Unsigned Long Background, FontColor, MouseScroll, DefaultFontSize, CurrentImage
Dim Shared As String UserText, BackgroundName, FontColorName
Dim Shared As Long CurrentFG, CurrentBG, PrintMode
GetFonts Font()
CleanFontList Font()
GetColors
UserText = "Hello World"
DefaultFontSize = 24
CurrentFG = 262: CurrentBG = 236
FontColor = White: FontColorName = "White"
Background = SkyBlue: BackgroundName = "SkyBlue"
CurrentImage = -11
PrintMode = 3
Do
Cls , 0
MouseScroll = 0
While _MouseInput
MouseScroll = MouseScroll + _MouseWheel
Wend
DropDownFontList 100, 420, 300, Font()
Sizer 420, 420
GetText 100, 470, 300
ChangeImage 540, 420, 150, 150
ChangeColors
ChoosePrintMode
Preview
_Limit 30
_Display
Loop Until _KeyDown(32)
System
Sub ChoosePrintMode
Static oldmb
mb = _MouseButton(1)
x1 = 420: x2 = 454: x3 = 488
y = 470: wide = 30: tall = 36
_Font 16
Line (x1, y)-Step(wide + 2, tall + 2), Gold, BF
Line (x2, y)-Step(wide + 2, tall + 2), Gold, BF
Line (x3, y)-Step(wide + 2, tall + 2), Gold, BF
If mb And Not oldmb Then
If _MouseY >= y And _MouseY <= y + tall + 2 Then
If _MouseX >= x1 And _MouseX <= x1 + wide + 2 Then PrintMode = 1
If _MouseX >= x2 And _MouseX <= x2 + wide + 2 Then PrintMode = 2
If _MouseX >= x3 And _MouseX <= x3 + wide + 2 Then PrintMode = 3
End If
End If
oldmb = mb
If PrintMode = 1 Then
Line (x1 + 1, y + 1)-Step(wide, tall), SkyBlue, BF
Else
Line (x1 + 1, y + 1)-Step(wide, tall), LightGray, BF
End If
If PrintMode = 2 Then
Line (x2 + 1, y + 1)-Step(wide, tall), SkyBlue, BF
Else
Line (x2 + 1, y + 1)-Step(wide, tall), LightGray, BF
End If
If PrintMode = 3 Then
Line (x3 + 1, y + 1)-Step(wide, tall), SkyBlue, BF
Else
Line (x3 + 1, y + 1)-Step(wide, tall), LightGray, BF
End If
UCprint 428, 475, Black, 0, "NO"
UCprint 428, 493, Black, 0, "BG"
UCprint 462, 475, Black, 0, "NO"
UCprint 462, 493, Black, 0, "FG"
UCprint 493, 482, Black, 0, "ALL"
End Sub
Sub ChangeColors
x1 = 100: x2 = 320
y = 530
wide = 200: tall = 32
Line (x1, y)-Step(wide + 4, tall + 4), Gold, BF
Line (x1 + 2, y + 2)-Step(wide, tall), FontColor, BF
If _KeyDown(100304) Or _KeyDown(100303) Then MouseScroll = _Ceil(MouseScroll / 20 * UBound(Kolor))
If _MouseY >= y And _MouseY <= y + 36 Then
If _MouseX >= x1 And _MouseX <= x1 + wide + 4 Then
CurrentFG = CurrentFG + MouseScroll
If CurrentFG < 0 Then CurrentFG = UBound(Kolor)
If CurrentFG > UBound(Kolor) Then CurrentFG = 0
FontColor = Kolor(CurrentFG).kolor
FontColorName = Kolor(CurrentFG).name
End If
If _MouseX >= x2 And _MouseX <= x2 + wide + 4 Then
CurrentBG = CurrentBG + MouseScroll
If CurrentBG < 0 Then CurrentBG = UBound(Kolor)
If CurrentBG > UBound(Kolor) Then CurrentBG = 0
Background = Kolor(CurrentBG).kolor
BackgroundName = Kolor(CurrentBG).name
End If
End If
h = (tall - _UFontHeight) \ 2
w = (wide - _UPrintWidth(FontColorName)) \ 2
w2 = (wide - _UPrintWidth(BackgroundName)) \ 2
Line (x2, y)-Step(wide + 4, tall + 4), Gold, BF
Line (x2 + 2, y + 2)-Step(wide, tall), Background, BF
UCprint x1 + w, y + h, Black, 0, FontColorName
UCprint x2 + w2, y + h, Black, 0, BackgroundName
UCprint x1 + w, y + h + 35, White, 0, FontColorName
UCprint x2 + w2, y + h + 35, White, 0, BackgroundName
End Sub
Sub GetColors
file$ = "..\internal\support\color\color32.bi"
If _FileExists(file$) = 0 Then Exit Sub 'bad path, bad file... some glitch... we can't work
Open file$ For Binary As #1
ReDim Kolor(1000) As Color_Type
Do Until EOF(1)
Line Input #1, text$
If UCase$(Left$(text$, 5)) = "CONST" Then
count = count + 1
text$ = Mid$(text$, 7) 'strip off the CONST and space
l = InStr(text$, "=")
Kolor(count).name = Left$(text$, l - 4)
Kolor(count).kolor = Val(Mid$(text$, l + 2))
End If
Loop
Close
ReDim _Preserve Kolor(count) As Color_Type
End Sub
Sub ChangeImage (x, y, wide, tall)
Static oldmb
mb = _MouseButton(1)
Line (x, y)-Step(wide + 4, tall + 4), Gold, BF
Line (x + 2, y + 2)-Step(wide, tall), Background, BF
If _MouseX >= x And _MouseX <= x + wide + 4 Then
If _MouseY >= y And _MouseY <= y + tall + 4 Then
If mb And Not oldmb Then
If CurrentImage <> 0 And CurrentImage <> -11 Then _FreeImage CurrentImage
result$ = _OpenFileDialog$("Background Image", , ".png|*.jpg|*.bmp|*.gif", "Image File")
If result$ <> "" Then
CurrentImage = _LoadImage(result$, 32)
Else
CurrentImage = 0
End If
End If
End If
End If
If CurrentImage <> 0 Then _PutImage (x + 2, y + 2)-Step(wide, tall), CurrentImage
oldmb = mb
End Sub
Sub Preview
Static As Long f, oldf, OldFontSize
Static As String OldfontName
Line (100, 100)-(700, 400), Gold, BF
Line (102, 102)-(698, 398), Background, BF
If CurrentImage <> 0 Then _PutImage (102, 102)-(698, 398), CurrentImage
x = 100: y = 100
If OldfontName <> DefaultFont.name Or OldFontSize <> DefaultFontSize Then
If DefaultFont.name <> "No Font List Loaded" Then
oldf = f
f = _LoadFont(DefaultFont.dir, DefaultFontSize)
If f > 0 Then
_Font f
'OldfontName = DefaultFont.name
'OldFontSize = DefaultFontSize
End If
End If
If oldf <> f Then
If oldf > 31 Then _FreeFont oldf
End If
End If
Select Case PrintMode
Case 1: _PrintMode _KeepBackground
Case 2: _PrintMode _OnlyBackground
Case 3: _PrintMode _FillBackground
End Select
h = (300 - _UFontHeight) \ 2
w = (600 - _UPrintWidth(UserText)) \ 2
UCprint x + w, y + h, FontColor, Background, UserText
_PrintMode _FillBackground
End Sub
Sub GetText (x, y, wide)
Static oldmb
mb = _MouseButton(1)
Line (x, y)-Step(wide + 4, 36), Gold, BF
Line (x + 2, y + 2)-Step(wide, 32), SkyBlue, BF
If _MouseX >= x And _MouseX <= x + wide + 4 Then
If _MouseY >= y And _MouseY <= y + 36 Then
If mb And Not oldmb Then
result$ = _Trim$(_InputBox$("Text to Preview", "Enter text to preview", UserText$))
If result$ <> "" Then UserText$ = result$
End If
End If
End If
out$ = UserText
w = (wide - _UPrintWidth(out$)) \ 2
UCprint x + w, y + 6, MidnightBlue, 0, out$
oldmb = mb
End Sub
Sub Sizer (x, y)
Line (x, y)-Step(100, 36), Gold, BF
Line (x + 2, y + 2)-Step(96, 32), SkyBlue, BF
If _MouseX >= x And _MouseX <= x + 100 Then
If _MouseY >= y And _MouseY <= y + 36 Then
If _KeyDown(100304) Or _KeyDown(100303) Then MouseScroll = MouseScroll * 10
DefaultFontSize = DefaultFontSize + MouseScroll
If DefaultFontSize < 4 Then DefaultFontSize = 128
If DefaultFontSize > 128 Then DefaultFontSize = 4
End If
End If
out$ = _Trim$(Str$(DefaultFontSize))
w = (96 - _UPrintWidth(out$)) \ 2
UCprint x + w, y + 6, MidnightBlue, 0, out$
End Sub
Sub DropDownFontList (x, y, wide, fontlist() As Font_type)
Shared Font() As Font_type
Static As Long f, CurrentFont
If UBound(Font) = 0 Then
DefaultFont.name = "No Font List Loaded"
DefaultFont.dir = ""
CurrentFont = 0
f = 16
oldf = 16
End If
If DefaultFont.name = "" Then
CurrentFont = 1
DefaultFont.name = Font(1).name
DefaultFont.dir = Font(1).dir
End If
If _MouseX >= x And _MouseX <= x + wide + 4 Then
If _MouseY >= y And _MouseY <= y + 36 Then
If CurrentFont > 0 Then
If _KeyDown(100304) Or _KeyDown(100303) Then MouseScroll = _Ceil(MouseScroll * UBound(fontlist) / 10)
CurrentFont = CurrentFont + MouseScroll
If CurrentFont < 1 Then CurrentFont = UBound(fontlist)
If CurrentFont > UBound(fontlist) Then CurrentFont = 1
DefaultFont.name = Font(CurrentFont).name
DefaultFont.dir = Font(CurrentFont).dir
f = _LoadFont(DefaultFont.dir, 24)
End If
End If
End If
If f = 0 Then 'initialize the font handle for the first time
f = _LoadFont(DefaultFont.dir, 24)
oldf = f
End If
If oldf <> f Then
Print f, oldf
If oldf <> 0 Then _FreeFont oldf
_Font f
End If
If _UPrintWidth(DefaultFont.name) > wide - 4 Then
For i = 1 To Len(DefaultFont.name)
out$ = Left$(DefaultFont.name, i)
If _UPrintWidth(out$) > wide Then
out$ = Left$(out$, i - 1)
Exit For
End If
Next
Else
out$ = DefaultFont.name
End If
Line (x, y)-Step(wide + 4, 36), Gold, BF
Line (x + 2, y + 2)-Step(wide, 32), SkyBlue, BF
w = (wide - _UPrintWidth(out$)) \ 2
UCprint x + w, y + 6, MidnightBlue, 0, out$
oldf = f
End Sub
Sub UCprint (x, y, kolor As _Unsigned Long, bkg As _Unsigned Long, text$)
d = _DefaultColor: B = _BackgroundColor
Color kolor, bkg
_UPrintString (x, y), text$
Color d, B
End Sub
Sub CleanFontList (FontList() As Font_type)
For i = 1 To UBound(FontList)
P = _InStrRev(FontList(i).name, "(") 'strip off the (True Type) type id
If P Then FontList(i).name = Left$(FontList(i).name, P - 1)
Next
End Sub
Sub GetFonts (FontList() As Font_type)
BypassStupidSHELL
F = FreeFile
Open "temp.txt" For Binary As #F
ReDim FontList(0) As Font_type
If LOF(1) Then
Do
Line Input #1, temp$
Select Case Right$(UCase$(temp$), 4)
Case "FON", "FNT", "PCF", "BDF"
_Continue
End Select
P = InStr(temp$, "REG_SZ")
If P Then
l$ = _Trim$(Left$(temp$, P - 1))
r$ = _Trim$(Mid$(temp$, P + 7))
count = count + 1
If UBound(FontList) < count Then
ReDim _Preserve FontList(count + 1000) As Font_type
End If
FontList(count).name = l$
FontList(count).dir = r$
End If
Loop Until EOF(1)
End If
Close #F
Kill "temp.txt"
ReDim _Preserve FontList(count) As Font_type
'a quick and simple combsort to make certain our list is in alphabetical order
gap = count
Do
gap = 10 * gap \ 13
If gap < 1 Then gap = 1
i = 1
swapped = 0
Do
If FontList(i).name > FontList(i + gap).name Then
Swap FontList(i).name, FontList(i + gap).name
Swap FontList(i).dir, FontList(i + gap).dir
swapped = -1
End If
i = i + 1
Loop Until i + gap > count
Loop Until gap = 1 And swapped = 0
End Sub
Sub BypassStupidSHELL
f = FreeFile
Open "makelist.bat" For Output As #f
Print #f, "reg query " + Chr$(34) + "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts" + Chr$(34) + " /s > temp.txt"
Close f
Open "temp.txt" For Output As #f: Close f
Shell _Hide "makelist.bat"
Kill "makelist.bat"
End Sub
Posts: 2,899
Threads: 341
Joined: Apr 2022
Reputation:
262
03-03-2025, 09:08 PM
(This post was last modified: 03-03-2025, 09:10 PM by SMcNeill.)
(03-03-2025, 08:56 PM)Steffan-68 Wrote: I also found something that I also liked very much.
I just don't know who wrote it, but it is definitely not from me.
/wave
That's definitely a Steve(tm) program. 
https://qb64phoenix.com/forum/showthread...4#pid23854
Posts: 88
Threads: 3
Joined: Apr 2022
Reputation:
17
(03-03-2025, 09:08 PM)SMcNeill Wrote: (03-03-2025, 08:56 PM)That's definitely a Steve(tm) program. Wrote:
https://qb64phoenix.com/forum/showthread...4#pid23854 I could have imagined it who it was, just didn't think of it. I'm getting old too. 
|
