03-17-2024, 11:15 PM
Code: (Select All)
$Color:32
Type Font_type
name As String
dir As String
End Type
_Icon
Screen _NewImage(800, 600, 32)
ReDim As Font_type Font(0)
ReDim Shared As Font_type DefaultFont
Dim Shared As _Unsigned Long Background, FontColor, MouseScroll, DefaultFontSize, CurrentImage
Dim Shared As String UserText
GetFonts Font()
CleanFontList Font()
UserText = "Hello World"
DefaultFontSize = 24
FontColor = White
Background = SkyBlue
CurrentImage = -11
Do
Cls , 0
MouseScroll = 0
While _MouseInput
MouseScroll = MouseScroll + _MouseWheel
Wend
DropDownFontList 100, 420, 300, Font()
Sizer 420, 420
GetText 100, 470, 300
Preview
ChangeImage 540, 420, 150, 150
_Limit 30
_Display
Loop Until _KeyDown(32)
System
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
h = (300 - _UFontHeight) \ 2
w = (600 - _UPrintWidth(UserText)) \ 2
UCprint x + w, y + h, FontColor, Background, UserText
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
We now have a way to change the user text that they want to preview, as well as a way to change our background image.
All that's left now is to fix this so that we can load and edit the font color and font background color.
