Code: (Select All)
'Option _Explicit
Screen _NewImage(800, 600, 32)
'$Console:Only
Type Font_Name_Type
Name As String
FileName As String
End Type
ReDim Shared As Font_Name_Type Fonts(10000), MonoFonts(10000)
Screen _NewImage(1280, 720, 32)
GetFontList
GetMonoFontList
numbered = -1 'number our quick list
l = 20 'number of lines to print to the screen
w = 50 'width to print to the screen
Do
Cls
_Limit 30
k = _KeyHit
Select Case k
Case 20480: s = s + 1: If s > UBound(Fonts) Then s = UBound(Fonts)
Case 18432: s = s - 1: If s < 0 Then s = 0
End Select
Locate 3, 20: Print "FONT NAME"
Locate 3, 70: Print "FILE NAME"
Locate 5
start = s: finish = s + l - 1
For i = start To finish
If i > UBound(Fonts) Then _Continue
If numbered Then counter$ = LTrim$(Str$(i)) + ") "
Locate , 10: Print counter$ + Left$(Fonts(i).Name, w);
Locate , 70: Print Fonts(i).FileName
Next
Locate 28, 15: Print "MONOSPACE FONT NAME"
Locate 28, 70: Print "FILE NAME"
Locate 30
For i1 = 0 To UBound(MonoFonts)
If numbered Then counter$ = LTrim$(Str$(i1)) + ") "
Locate , 10: Print counter$ + Left$(MonoFonts(i1).Name, w);
Locate , 70: Print Left$(MonoFonts(i1).FileName, w)
Next
_Display
Loop Until k = 27
System
Sub GetFontList
Shell "Powershell -command " + Chr$(34) + "$Host.UI.RawUI.BufferSize = New-Object Management.Automation.Host.Size (500, 50); Get-ItemProperty 'HKLM:\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts'|Out-File -Encoding Ascii 'temp_fontlist.txt'" + Chr$(34)
If _FileExists("temp_fontlist.txt") Then
f = FreeFile
Open "temp_fontlist.txt" For Binary As #f
Do Until EOF(1)
Line Input #1, temp$
sep = InStr(temp$, ":")
l$ = _Trim$(Left$(temp$, sep - 1))
r$ = _Trim$(Mid$(temp$, sep + 1))
If l$ <> "PSPath" Then
If l$ <> "" Then ' skip the blank space lines
Fonts(count).Name = l$
Fonts(count).FileName = r$
count = count + 1
End If
Else
Exit Do ' we can stop reading files at this point (according to my tests)
End If
Loop
Close f
Kill "temp_fontlist.txt" ' clean up the file after we're done with parsing it.
count = count - 1 ' adjust for that last count + 1, which we didn't use.
ReDim _Preserve Fonts(count) As Font_Name_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 = 0
swapped = 0
Do
If Fonts(i).Name > Fonts(i + gap).Name Then
Swap Fonts(i).Name, Fonts(i + gap).Name
Swap Fonts(i).FileName, Fonts(i + gap).FileName
swapped = -1
End If
i = i + 1
Loop Until i + gap > count
Loop Until gap = 1 And swapped = 0
Else 'very poor error handling here
Print "Powershell failed to create font list."
Beep
Sleep
Exit Sub
End If
End Sub
Sub GetMonoFontList
count = UBound(Fonts)
newcount = 0
f = _Font
For i = 0 To count
f$ = Fonts(i).FileName
If UCase$(Right$(f$, 4)) = ".FON" Then _Continue
temp = _LoadFont(f$, 12)
_Font temp
'no need to check all characters. I chose to just check the ones that tend to vary the greatest
pw = _PrintWidth("W"): pw1 = _PrintWidth("l")
If pw = pw1 Then
pw2 = _PrintWidth(" ")
If pw = pw2 Then
pw3 = _PrintWidth(".")
If pw = pw3 Then
MonoFonts(newcount).Name = Fonts(i).Name
MonoFonts(newcount).FileName = Fonts(i).FileName
newcount = newcount + 1
End If
End If
End If
_Font f
_FreeFont temp
Next
newcount = newcount - 1
If newcount >= 0 Then ReDim _Preserve MonoFonts(newcount) As Font_Name_Type
End Sub
Sub Pause (time As _Float, exclude_code As Long)
'exclude_code is the binary value of things we don't want to allow to break Pause
'1 = No brealing pause if Window lost focus
'2 = No Mouse breaking pause
'4 - No Keyboard breaking pause
'8 - No Keyup events break pause
'16 - No modifier keys breaking pause (Shift/Ctrl/Alt)
Dim t As _Float, k As Long, d As String
d = Date$: t = Timer + time
Do
_Limit 10 'we're a pause. We don't need to do a bunch of crap per second.
If (exclude_code And 1) Then 'don't unpause until window has focus or time has ran out
If _WindowHasFocus = 0 Then _Continue
End If
If (exclude_code And 2) = 0 Then 'mouse clicks break pause
While _MouseInput: Wend
If _MouseButton(1) Or _MouseButton(2) Then Exit Do
End If
If (exclude_code And 4) = 0 Then 'we allow keyboard input (of some sort) to break pause
k = _KeyHit
If (exclude_code And 8) Then If k < 0 Then k = 0 'but we don't allow keyup events to do it
If (exclude_code And 16) Then 'here we don't allow modifier keys to do it
Select Case k
Case 100304, 100303, -100304, -100303 'shift up/down
_Continue
Case 100306, 100305, -100306, -100305 'ctrl up/down
_Continue
Case 100308, 100307, -100308, -100307 'alt up/down
_Continue
End Select
End If
End If
If d <> Date$ Then d = Date$: t = t - 86400 'adjust for midnight by subtracting a day from the counter
If time <> 0 And Timer > t Then Exit Do
If k <> 0 Then Exit Do
Loop
End Sub
Function Format$ (num As _Float, using$)
Static tempimage As Long
Dim As Long d, s, i, p
Dim As String text
If tempimage = 0 Then tempimage = _NewImage(80, 1, 0)
d = _Dest: s = _Source
_Dest tempimage: _Source tempimage
Cls
Print Using using$; num;
For i = 1 To 80
p = Screen(1, i)
If p = 0 Then Exit For
text$ = text$ + Chr$(p)
Next
_Dest d: _Source s
Format$ = text$
End Function
Function SwapEnd~&& (num As _Unsigned _Integer64, biteSize As Integer)
'One command to swap endianness for int64, long, and integer type variables. Supply the value and the bite size.
Dim temp As _Unsigned _Integer64, temp1 As _Unsigned Long, temp2 As _Unsigned Integer
Select Case biteSize
Case 8 'integer64
temp = _ShL(num And &HFF&&, 56) 'byte #1
temp = temp Or _ShL(num And &HFF00&&, 40) '2
temp = temp Or _ShL(num And &HFF0000&&, 24) '3
temp = temp Or _ShL(num And &HFF000000&&, 8) '4
temp = temp Or _ShR(num And &HFF00000000&&, 8) '5
temp = temp Or _ShR(num And &HFF0000000000&&, 24) '6
temp = temp Or _ShR(num And &HFF000000000000&&, 40) '7
temp = temp Or _ShR(num And &HFF00000000000000&&, 56) '8
SwapEnd = temp
Case 4 'long
temp1 = _ShL(num And &HFF~&, 24)
temp1 = temp1 Or _ShL(num And &HFF00~&, 8)
temp1 = temp1 Or _ShR(num And &HFF0000~&, 8)
temp1 = temp1 Or _ShR(num And &HFF000000~&, 24)
SwapEnd = temp1
Case 2 'integer
temp2 = temp2 Or _ShL(num And &HFF~%, 8) '1
temp2 = temp2 Or _ShR(num And &HFF00~%, 8) '2
SwapEnd = temp2
End Select
End Function
Function Convert.HBO$ (in As String) 'Convert Hex, Binary, Oct to Decimal values inside a string
'Note that this converts all the hex/binary/octal values inside a whole string.
'It doesn't stop at just the first instance to convert
Dim As String temp, vc, m, t
Dim As Long finished, Cpos, EndPos
Dim ub As _Unsigned _Bit, b As _Bit
Dim ubyte As _Unsigned _Byte, byte As _Byte
Dim ui As _Unsigned Integer, i As Integer
Dim ul As _Unsigned Long, l As Long
Dim ui64 As _Unsigned _Integer64, i64 As _Integer64
temp = _Trim$(UCase$(in))
Do
finished = -1
Cpos = String.Find(temp, "&H", 1)
If Cpos Then '&H located
EndPos = 2: finished = 0
vc = "01234567889ABCDEF": GoSub endposition 'get the hex characters
GoSub typesymbol
temp = Left$(temp, Cpos - 1) + " " + m + Mid$(temp, Cpos + EndPos)
End If
Cpos = String.Find(temp, "&B", 1)
If Cpos Then '&B located
EndPos = 2: finished = 0
vc = "01": GoSub endposition 'get the binary characters
GoSub typesymbol
temp = Left$(temp, Cpos - 1) + " " + m + Mid$(temp, Cpos + EndPos)
End If
Cpos = String.Find(temp, "&O", 1)
If Cpos Then '&O located
EndPos = 2: finished = 0
vc = "01234567": GoSub endposition 'get the octal characters
GoSub typesymbol
temp = Left$(temp, Cpos - 1) + " " + m + Mid$(temp, Cpos + EndPos)
End If
Loop Until finished
Convert.HBO = temp
Exit Function
endposition:
Do
m = Mid$(temp, Cpos + EndPos, 1)
If m = "" Then Exit Do
If InStr(vc, m) Then EndPos = EndPos + 1 Else Exit Do
Loop
Return
typesymbol:
Dim datatype As Long
t = Left$(Mid$(temp, Cpos + EndPos, 3) + " ", 3)
m = Mid$(temp, Cpos, EndPos)
If Left$(t, 1) = "~" Then 'unsigned
t = Mid$(t, 2) 'unsigned + 2 characters to the right for identification
Select Case Left$(t, 1)
Case "`": ub = Val(m): m = _ToStr$(ub): EndPos = EndPos + 2 'bit
Case "%" 'integer or byte
Select Case Right$(t, 1)
Case "%": ubyte = Val(m): m = _ToStr$(ubyte): EndPos = EndPos + 3 'byte
Case Else: ui = Val(m): m = _ToStr$(ui): EndPos = EndPos + 2 'integer
End Select
Case "&" 'long or integer64
Select Case Right$(t, 1)
Case "&": ui64 = Val(m): m = _ToStr$(ui64): EndPos = EndPos + 3 'integer64
Case Else: ul = Val(m): m = _ToStr$(ul): EndPos = EndPos + 2 'long
End Select
End Select
Else
t = Left$(t, 2)
Select Case Left$(t, 1)
Case "`": b = Val(m): m = _ToStr$(b): EndPos = EndPos + 1 'bit
Case "%" 'integer or byte
Select Case Right$(t, 1)
Case "%": byte = Val(m): m = _ToStr$(byte): EndPos = EndPos + 2 'integer
Case Else: i = Val(m): m = _ToStr$(i): EndPos = EndPos + 1 'byte
End Select
Case "&" 'long or integer64
Select Case Right$(t, 1)
Case "&": i64 = Val(m): m = _ToStr$(i64): EndPos = EndPos + 2 'integer64
Case Else: l = Val(m): m = _ToStr$(l): EndPos = EndPos + 1 'long
End Select
Case Else
Select Case Len(m)
Case Is <= 6: i = Val(m): m = _ToStr$(i)
Case Is <= 10: l = Val(m): m = _ToStr$(l)
Case Else: i64 = Val(m): m = _ToStr$(i64)
End Select
End Select
End If
Return
End Function
Function String.Find& (Content As String, Search As String, CountTo As Long)
'If CountTo is 0, this routine will count the number of instances of the search term inside the content string
'If CountTo is >0, this routine will find the position of that instance, if it exists, inside the search string.
'For example, CountTo = 2, it'll find the location of the 2nd instance of the search term, skipping the first.
If CountTo < 0 Then Exit Function 'Can't find a negative position.
Dim As Long p, l, count
If Search$ = "" Then Exit Function
p = InStr(Content$, Search$)
l = Len(Search$)
Do While p& > 0
count = count + 1
If CountTo = count Then String.Find = p: Exit Function
p = InStr(p + l, Content$, Search$)
Loop
If CountTo = 0 Then String.Find = count
End Function
Function String.Replace$ (content$, from$, to$, position As Long)
Dim found As Long: found = String.Find(content$, from$, position)
If found Then String.Replace = Left$(content$, found - 1) + to$ + Mid$(content$, found + Len(from$))
End Function
Function String.Replace.All$ (content$, from$, to$)
'Inspired by the forum post here: https://qb64phoenix.com/forum/showthread...9#pid33559
'Original credit goes to mdijkens as I just tweaked it a little to make it a bit more library friendly
$Checking:Off
Dim As Long mp, pp, found, flen, tlen, p
Dim m As _MEM
Dim As String content2
found = String.Find(content$, from$, 0)
flen = Len(from$): tlen = Len(to$)
m = _MemNew(Len(content$) + (tlen& - flen&) * found): mp = 0: pp = 1
p = InStr(content$, from$)
Do While p > 0
_MemPut m, m.OFFSET + mp, Mid$(content$, pp, p& - pp): mp = mp + p& - pp
_MemPut m, m.OFFSET + mp, to$: mp = mp + tlen&: pp = p& + flen&
p& = InStr(p + flen&, content$, from$)
Loop
_MemPut m, m.OFFSET + mp, Mid$(content$, pp): mp = mp + Len(Mid$(content$, pp))
content2$ = Space$(mp): _MemGet m, m.OFFSET, content2$: _MemFree m
String.Replace.All$ = content2$
$Checking:On
End Function
Function Color.Find& (targetColor As _Unsigned Long, Pal() As _Unsigned Long)
Dim As Long tr, tg, tb, colors, bestdist
Dim As Long bestIndex, dr, dg, db, i, dist
Dim As _Unsigned Long c
tr = _Red32(targetColor): tg = _Green32(targetColor): tb = _Blue32(targetColor):
colors = UBound(Pal): bestdist = _LONG_MAX
$Checking:Off
While i < colors
c = Pal(i)
dr = tr - _Red32(c)
dg = tg - _Green32(c)
db = tb - _Blue32(c)
dist = dr * dr + dg * dg + db * db
If dist < bestdist Then
If dist = 0 Then Color.Find& = i: Exit Function
bestdist = dist: bestIndex = i
End If
i = i + 1
Wend
$Checking:On
Color.Find& = bestIndex
End Function
Sub MemSort (m As _MEM)
Dim i As _Unsigned Long
Dim As Long DataType, i1, gap, swapped
$If 64BIT Then
Dim ES As _Integer64, EC As _Integer64
$Else
DIM ES AS LONG, EC AS LONG
$End If
If Not m.TYPE And 65536 Then Exit Sub 'We won't work without an array
If m.TYPE And 1024 Then DataType = 10
If m.TYPE And 1 Then DataType = DataType + 1
If m.TYPE And 2 Then DataType = DataType + 2
If m.TYPE And 4 Then If m.TYPE And 128 Then DataType = DataType + 4 Else DataType = 3
If m.TYPE And 8 Then If m.TYPE And 128 Then DataType = DataType + 8 Else DataType = 5
If m.TYPE And 32 Then DataType = 6
If m.TYPE And 512 Then DataType = 7
'Convert our offset data over to something we can work with
Dim m1 As _MEM: m1 = _MemNew(Len(ES))
_MemPut m1, m1.OFFSET, m.ELEMENTSIZE: _MemGet m1, m1.OFFSET, ES 'Element Size
_MemPut m1, m1.OFFSET, m.SIZE: _MemGet m1, m1.OFFSET, EC 'Element Count will temporily hold the WHOLE array size
_MemFree m1
EC = EC / ES - 1 'Now we take the whole element size / the size of the elements and get our actual element count. We subtract 1 so our arrays start at 0 and not 1.
'And work with it!
Dim o As _Offset, o1 As _Offset, counter As _Unsigned Long
Select Case DataType
Case 1 'BYTE
Dim temp1(-128 To 127) As _Unsigned Long
Dim t1 As _Byte
i = 0
Do
_MemGet m, m.OFFSET + i, t1
temp1(t1) = temp1(t1) + 1
i = i + 1
Loop Until i > EC
i1 = -128
Do
Do Until temp1(i1) = 0
_MemPut m, m.OFFSET + counter, i1 As _Byte
counter = counter + 1
temp1(i1) = temp1(i1) - 1
If counter > EC Then Exit Sub
Loop
i1 = i1 + 1
Loop Until i1 > 127
Case 2: 'INTEGER
Dim temp2(-32768 To 32767) As _Unsigned Long
Dim t2 As Integer
i = 0
Do
_MemGet m, m.OFFSET + i * 2, t2
temp2(t2) = temp2(t2) + 1
i = i + 1
Loop Until i > EC
i1 = -32768
Do
Do Until temp2(i1) = 0
_MemPut m, m.OFFSET + counter * 2, i1 As Integer
counter = counter + 1
temp2(i1) = temp2(i1) - 1
If counter > EC Then Exit Sub
Loop
i1 = i1 + 1
Loop Until i1 > 32767
Case 3 'SINGLE
Dim T3a As Single, T3b As Single
gap = EC
Do
gap = 10 * gap \ 13
If gap < 1 Then gap = 1
i = 0
swapped = 0
Do
o = m.OFFSET + i * 4
o1 = m.OFFSET + (i + gap) * 4
If _MemGet(m, o, Single) > _MemGet(m, o1, Single) Then
_MemGet m, o1, T3a
_MemGet m, o, T3b
_MemPut m, o1, T3b
_MemPut m, o, T3a
swapped = -1
End If
i = i + 1
Loop Until i + gap > EC
Loop Until gap = 1 And swapped = 0
Case 4 'LONG
Dim T4a As Long, T4b As Long
gap = EC
Do
gap = 10 * gap \ 13
If gap < 1 Then gap = 1
i = 0
swapped = 0
Do
o = m.OFFSET + i * 4
o1 = m.OFFSET + (i + gap) * 4
If _MemGet(m, o, Long) > _MemGet(m, o1, Long) Then
_MemGet m, o1, T4a
_MemGet m, o, T4b
_MemPut m, o1, T4b
_MemPut m, o, T4a
swapped = -1
End If
i = i + 1
Loop Until i + gap > EC
Loop Until gap = 1 And swapped = 0
Case 5 'DOUBLE
Dim T5a As Double, T5b As Double
gap = EC
Do
gap = 10 * gap \ 13
If gap < 1 Then gap = 1
i = 0
swapped = 0
Do
o = m.OFFSET + i * 8
o1 = m.OFFSET + (i + gap) * 8
If _MemGet(m, o, Double) > _MemGet(m, o1, Double) Then
_MemGet m, o1, T5a
_MemGet m, o, T5b
_MemPut m, o1, T5b
_MemPut m, o, T5a
swapped = -1
End If
i = i + 1
Loop Until i + gap > EC
Loop Until gap = 1 And swapped = 0
Case 6 ' _FLOAT
Dim T6a As _Float, T6b As _Float
gap = EC
Do
gap = 10 * gap \ 13
If gap < 1 Then gap = 1
i = 0
swapped = 0
Do
o = m.OFFSET + i * 32
o1 = m.OFFSET + (i + gap) * 32
If _MemGet(m, o, _Float) > _MemGet(m, o1, _Float) Then
_MemGet m, o1, T6a
_MemGet m, o, T6b
_MemPut m, o1, T6b
_MemPut m, o, T6a
swapped = -1
End If
i = i + 1
Loop Until i + gap > EC
Loop Until gap = 1 And swapped = 0
Case 7 'String
Dim T7a As String, T7b As String, T7c As String
T7a = Space$(ES): T7b = Space$(ES): T7c = Space$(ES)
gap = EC
Do
gap = Int(gap / 1.247330950103979)
If gap < 1 Then gap = 1
i = 0
swapped = 0
Do
o = m.OFFSET + i * ES
o1 = m.OFFSET + (i + gap) * ES
_MemGet m, o, T7a
_MemGet m, o1, T7b
If T7a > T7b Then
T7c = T7b
_MemPut m, o1, T7a
_MemPut m, o, T7c
swapped = -1
End If
i = i + 1
Loop Until i + gap > EC
Loop Until gap = 1 And swapped = 0
Case 8 '_INTEGER64
Dim T8a As _Integer64, T8b As _Integer64
gap = EC
Do
gap = 10 * gap \ 13
If gap < 1 Then gap = 1
i = 0
swapped = 0
Do
o = m.OFFSET + i * 8
o1 = m.OFFSET + (i + gap) * 8
If _MemGet(m, o, _Integer64) > _MemGet(m, o1, _Integer64) Then
_MemGet m, o1, T8a
_MemGet m, o, T8b
_MemPut m, o1, T8b
_MemPut m, o, T8a
swapped = -1
End If
i = i + 1
Loop Until i + gap > EC
Loop Until gap = 1 And swapped = 0
Case 11: '_UNSIGNED _BYTE
Dim temp11(0 To 255) As _Unsigned Long
Dim t11 As _Unsigned _Byte
i = 0
Do
_MemGet m, m.OFFSET + i, t11
temp11(t11) = temp11(t11) + 1
i = i + 1
Loop Until i > EC
i1 = 0
Do
Do Until temp11(i1) = 0
_MemPut m, m.OFFSET + counter, i1 As _Unsigned _Byte
counter = counter + 1
temp11(i1) = temp11(i1) - 1
If counter > EC Then Exit Sub
Loop
i1 = i1 + 1
Loop Until i1 > 255
Case 12 '_UNSIGNED INTEGER
Dim temp12(0 To 65535) As _Unsigned Long
Dim t12 As _Unsigned Integer
i = 0
Do
_MemGet m, m.OFFSET + i * 2, t12
temp12(t12) = temp12(t12) + 1
i = i + 1
Loop Until i > EC
i1 = 0
Do
Do Until temp12(i1) = 0
_MemPut m, m.OFFSET + counter * 2, i1 As _Unsigned Integer
counter = counter + 1
temp12(i1) = temp12(i1) - 1
If counter > EC Then Exit Sub
Loop
i1 = i1 + 1
Loop Until i1 > 65535
Case 14 '_UNSIGNED LONG
Dim T14a As _Unsigned Long, T14b As _Unsigned Long
gap = EC
Do
gap = 10 * gap \ 13
If gap < 1 Then gap = 1
i = 0
swapped = 0
Do
o = m.OFFSET + i * 4
o1 = m.OFFSET + (i + gap) * 4
If _MemGet(m, o, _Unsigned Long) > _MemGet(m, o1, _Unsigned Long) Then
_MemGet m, o1, T14a
_MemGet m, o, T14b
_MemPut m, o1, T14b
_MemPut m, o, T14a
swapped = -1
End If
i = i + 1
Loop Until i + gap > EC
Loop Until gap = 1 And swapped = 0
Case 18: '_UNSIGNED _INTEGER64
Dim T18a As _Unsigned _Integer64, T18b As _Unsigned _Integer64
gap = EC
Do
gap = 10 * gap \ 13
If gap < 1 Then gap = 1
i = 0
swapped = 0
Do
o = m.OFFSET + i * 8
o1 = m.OFFSET + (i + gap) * 8
If _MemGet(m, o, _Unsigned _Integer64) > _MemGet(m, o1, _Unsigned _Integer64) Then
_MemGet m, o1, T18a
_MemGet m, o, T18b
_MemPut m, o1, T18b
_MemPut m, o, T18a
swapped = -1
End If
i = i + 1
Loop Until i + gap > EC
Loop Until gap = 1 And swapped = 0
End Select
End Sub
The above will generate, sort, and display a list of all the fonts which is installed on an user's Windows PC. This gives you both the font name and style (such as "Courier New Bold"), as well as the filename ("courbd.ttf", in this case).
(Code updated to the latest version in this thread, which should have fixes for terminal vs console, and also for too small of a console/terminal size.)
)