I did some research in the WinAPI calls.
I made a Font Dialog function.
r$ = SBChooseFont(16, rgb(255, 255, 255))
print "Font name: ", SBGetFontName(r$)
print "Font size: ", SBGetFontSize(r$)
print "Italic: ", SBGetFontItalic(r$)
print "Underline: ", SBGetFontUnderline(r$)
print "StrikeOut: ", SBGetFontStrikeOut(r$)
print "Bold: ", SBGetFontBold(r$)
ink SBGetFontColor(r$), 0
print "Font color: ", SBGetFontColor(r$)
print "press any key"
wait key
end
remstart
s$ = SBChooseFont(defaultSize, defaultColor)
defaultSize: Size automatically selected
defaultColor: Color automaticall selected
Returns:
a string containing the returned data.
The returned string is built as followed:
FontName;FontSize;boolItalic;boolUnderline;boolStrikeOut;boolBold;Color
you can get each parameter using the following commands
FontName$ = SBGetFontName(s$)
FontSize = SBGetFontSize(s$)
boolItalic = SBGetFontItalic(s$)
boolUnderline = SBGetFontUnderline(s$)
boolStrikeOut = SBGetFontStrikeOut(s$)
boolBold = SBGetFontBold(s$)
Color = SBGetFontColor(s$)
remend
function SBChooseFont(defaultSize, defaultColor)
`Find a free DLL
d = 0
repeat
inc d
until dll exist(d) = 0
`Load dll
load dll "User32.dll", d
handle = call dll(d, "GetForegroundWindow")
delete dll d
`Load dll
load dll "comdlg32.dll", d
`Find a free memblock - lpLogFont
mem1 = 0
repeat : inc mem1 : until memblock exist(mem1) = 0
make memblock mem1, 60
ptr1 = get memblock ptr(mem1)
`Initialize
write memblock dword mem1, 0, 0 : `Use default height
write memblock dword mem1, 4, 0 : `Use default width
write memblock dword mem1, 8, 0 : `No escapement
write memblock dword mem1, 12, 0 : `No orientation
write memblock dword mem1, 16, 400 : `Default weight
write memblock byte mem1, 20, 0 : `Italic
write memblock byte mem1, 21, 0 : `Underline
write memblock byte mem1, 22, 0 : `Strikeout
write memblock byte mem1, 23, 1 : `DEFAULT_CHARSET
write memblock byte mem1, 24, 0 : `OUT_DEFAULT_PRECIS
write memblock byte mem1, 25, 0 : `CLIP_DEFAULT_PRECIS
write memblock byte mem1, 26, 0 : `DEFAULT_QUALITY
write memblock byte mem1, 27, 0 || 0 : `DEFAULT_PITCH || FF_DONTCARE
`The rest is an empty string in the memblock
`Find a free memblock - lpszStyle
mem2 = 0
repeat : inc mem2 : until memblock exist(mem2) = 0
make memblock mem2, 60
ptr1 = get memblock ptr(mem2)
mem = 0
repeat : inc mem : until memblock exist(mem) = 0
`Create a pointer
size = 60
pointsize = defaultSize * 10
flags = 0x0001 + 0x0100 + 0x00000080 : `CF_SCREENFONTS + CF_EFFECTS + CF_USESTYLE
`Create main memblock
make memblock mem, size
`Write data
write memblock dword mem, 0, size
write memblock dword mem, 4, handle
write memblock dword mem, 8, 0
write memblock dword mem, 12, ptr1
write memblock dword mem, 16, pointsize
write memblock dword mem, 20, flags
write memblock byte mem, 24, rgbr(defaultColor)
write memblock byte mem, 25, rgbg(defaultColor)
write memblock byte mem, 26, rgbb(defaultColor)
write memblock byte mem, 27, 0
write memblock dword mem, 28, 0
write memblock dword mem, 32, 0
write memblock dword mem, 36, 0
write memblock dword mem, 40, 0
write memblock dword mem, 44, ptr2
write memblock dword mem, 48, 8
write memblock dword mem, 52, 50
ptr = get memblock ptr(mem)
`Call DLL
a = call dll(d, "ChooseFontA", ptr)
`Find point size (1/10 of a point)
PointSize = memblock dword(mem, 16) / 10
`Find color
Color = rgb(memblock byte(mem, 24), memblock byte(mem, 25), memblock byte(mem, 26))
`The lpszStyle has the same structure as lpLogFont - Read data
weight = memblock dword(mem2, 16)
if weight > 400 then Bold = 1 else Bold = 0
Italic = memblock byte(mem2, 20)
Underline = memblock byte(mem2, 21)
StrikeOut = memblock byte(mem2, 22)
`Read font name
FontName$ = ""
i = 28
repeat
FontName$ = FontName$ + chr$(memblock byte(mem2, i))
inc i
until memblock byte(mem2, i) = 0
`Check data
ret$ = FontName$ + ";" + str$(PointSize) + ";" + str$(Italic) + ";" + str$(Underline) + ";" + str$(StrikeOut) + ";" + str$(Bold) + ";" + str$(Color)
`Delete memblocks
delete memblock mem
delete memblock mem1
delete memblock mem2
endfunction ret$
`SBGetFontName
`s$: string exported by SBChooseFont
`returns: The font name in a string exported by SBChooseFont
function SBGetFontName(s$)
`Reset variables
ret$ = ""
i = 0
`Extract font name
repeat
ret$ = ret$ + mid$(s$, i)
inc i
until mid$(s$, i) = ";"
endfunction ret$
`SBGetFontSize
`s$: string exported by SBChooseFont
`returns: The font size in a string exported by SBChooseFont
function SBGetFontSize(s$)
`Reset variables
count = 0
i = 0
`Extract Italic
repeat
inc i
if mid$(s$, i) = ";" then inc count
until mid$(s$, i) = ";" and count = 1
`Extract size
inc i
repeat
ret$ = ret$ + mid$(s$, i)
inc i
until mid$(s$, i) = ";"
PointSize = val(ret$)
endfunction PointSize
`SBGetFontItalic
`s$: string exported by SBChooseFont
`returns: Italic parameter in a string exported by SBChooseFont
function SBGetFontItalic(s$)
`Reset variables
count = 0
i = 0
`Extract Italic
repeat
inc i
if mid$(s$, i) = ";" then inc count
until mid$(s$, i) = ";" and count = 2
Italic = val(mid$(s$, i + 1))
endfunction Italic
`SBGetFontUnderline
`s$: string exported by SBChooseFont
`returns: Underline parameter in a string exported by SBChooseFont
function SBGetFontUnderline(s$)
`Reset variables
count = 0
i = 0
`Extract Italic
repeat
inc i
if mid$(s$, i) = ";" then inc count
until mid$(s$, i) = ";" and count = 3
Underline = val(mid$(s$, i + 1))
endfunction Underline
`SBGetFontStrikeOut
`s$: string exported by SBChooseFont
`returns: StrikeOut parameter in a string exported by SBChooseFont
function SBGetFontStrikeout(s$)
`Reset variables
count = 0
i = 0
`Extract Italic
repeat
inc i
if mid$(s$, i) = ";" then inc count
until mid$(s$, i) = ";" and count = 4
Strike0ut = val(mid$(s$, i + 1))
endfunction Strike0ut
`SBGetFontBold
`s$: string exported by SBChooseFont
`returns: Bold parameter in a string exported by SBChooseFont
function SBGetFontBold(s$)
`Reset variables
count = 0
i = 0
`Extract Italic
repeat
inc i
if mid$(s$, i) = ";" then inc count
until mid$(s$, i) = ";" and count = 5
Bold = val(mid$(s$, i + 1))
endfunction Bold
`SBGetFontColor
`s$: string exported by SBChooseFont
`returns: Color in a string exported by SBChooseFont
function SBGetFontColor(s$)
`Reset variables
i = len(s$)
repeat
dec i
until mid$(s$, i) = ";"
f$ = right$(s$, len(s$) - i)
FontColor = val(f$)
endfunction FontColor
The documentation is in the remarks just before the functions.
It's the programmer's life:
Have a problem, solve the problem, and have a new problem to solve.
