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)
_Font f
OldfontName = DefaultFont.name
olffontsize = DefaultFontSize
End If
End If
If oldf <> f Then
If oldf > 31 Then _FreeFont oldf
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
As Dimster brought up here -- https://qb64phoenix.com/forum/showthread.php?tid=2505 -- there's no really great tool out there right now for previewing what text might look like on the screen; especially when changing colors/backgrounds/fonts/images.
This is the start of my solution to such a preview tool.
At the moment, this gets a list of all the fonts on an user's computer (Windows only), and it produces a preview pane with a background and font color, letting you choose your font and see how it'd look with that configuration.
