This code uses user23.dll and comdlg32.dll to call a standard Font Dialog box.
SBChooseFont(defaultSize, defaultColor)
- defaultSize: The default selected size for text
- defaultColor: The default selected color for text
returns string:
"(FontName);(FontSize);(boolItalic);(boolUnderline);(boolStrikeOut);(boolBold);(Color)"
You can extract each data by using the other functions:
SBGetFontName(s$), SBGetFontSize(s$), SBGetFontItalic(s$), SBGetFontUnderline(s$), SBGetFontStrikeOut(s$), SBGetFontBold(s$) and SBGetFontColor(s$) which each return their data in their own type.
Language:
Dark Basic Pro
Code:
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, "GetActiveWindow") 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
(1 vote)