Automatic Font Control

[Stan Durham]

automatic font control

this is a completely self-contained sample of a font control engine.

automatically loads over 900 fonts and does over 2000 font changes.

if a font is requested that isn’t loaded, it automatically loads it.
destroys all font handles on exit.

this sample doesn’t need the inc file, which is here. http://www.powerbasic.com/support/pb...ad.php?t=24783

' ==================================================
#compile exe
#dim all
' --------------------------------------------------
#include "win32api.inc"
%dlg_style = %ws_caption or %ws_minimizebox or %ws_sysmenu
%dlg_stylex = %ws_ex_left or %ws_ex_ltrreading or %ws_ex_appwindow
%timedelay = 100
' --------------------------------------------------
type fontenginetype
     pafont as string ptr 'font name array
     pahandle as long ptr 'font handle array
end type
' --------------------------------------------------
macro fnteng_wm_initdialog(gtfont)
    macrotemp fnteng__font, fnteng__handle
    global fnteng__font() as string   : redim fnteng__font()
    global fnteng__handle() as string : redim fnteng__handle()
    global gtfont as fontenginetype
    gtfont.pafont = varptr( fnteng__font() )
    gtfont.pahandle = varptr( fnteng__handle() )
end macro
' --------------------------------------------------
declare sub fnteng_set( gtfont as fontenginetype, hdlg&, id&, fontname$, fontsize&, fontbold&, fontitalic&, fontunderline&, fontstrikeout&, optional fgcolor&, optional bgcolor& )
declare sub fnteng_wm_destroy( gtfont as fontenginetype )
declare function fnteng_count( gtfont as fontenginetype ) as long
declare function fnteng_makefont( fontspec$ ) as long
declare function fnteng__aptrstrubound( byref arry() as string ) as long
declare function fnteng__aptrstrscannc( byref arry() as string, byval thevalue as string ) as long
declare sub fnteng__aptrstrappend( byref arry() as string, byval thevalue as string )
declare function fnteng__aptrlongget( byref arry() as long, ndx& ) as long
declare sub fnteng__aptrlongappend( byref arry() as long, byval thevalue as long )
' --------------------------------------------------
global hdlg as dword
declare function displayfonts(byval x as long) as long
' --------------------------------------------------
' --------------------------------------------------
function pbmain() as long
    local result&
    dialog new %hwnd_desktop, "title",,,400,100,%dlg_style,%dlg_stylex, to hdlg
    control add button, hdlg, 10, "font 1", 2, 2, 60, 14
    control add textbox, hdlg, 20, "click button to change font", 2, 18, 396, 80
    control add label, hdlg, 30, ", 66, 2, 60, 14
    control add label, hdlg, 40, ", 136, 2, 100, 14
    dialog show modal hdlg, call dlg1callback() to result&
end function
' --------------------------------------------------
' --------------------------------------------------
callback function dlg1callback()
    local hthread as dword
    select case as long cbmsg
        case %wm_initdialog
            fnteng_wm_initdialog(gtfont) '<<<<<<<<<<<<<<<<
        case %wm_command
            select case as long cbctl
                case 10
                    if cbctlmsg = %bn_clicked then
                        thread create displayfonts(0) to hthread
                    end if
            end select
        case %wm_destroy
            fnteng_wm_destroy gtfont '<<<<<<<<<<<<<<<<
    end select
end function
' --------------------------------------------------
' --------------------------------------------------
function displayfonts(byval x as long) as long
    local i as long
    local bold&, ital&, undrln&
    static fontsdisp&
    static fntsize&
    for i=1 to 300
        fntsize& = fntsize& + 1
        if fntsize&<8 then fntsize&=8
        if fntsize&>72 then fntsize&=8
        '''''''''''''''''''''''''''' change font
        incr fontsdisp&
        undrln& = not undrln&
        'bold& = not bold&
        ital& = not ital&
        fnteng_set gtfont, hdlg, 20, "arial", fntsize&, bold&, ital&, undrln&, 0, %red, %green
        control set text hdlg, 20, "arial" + str$(fntsize&)
        dialog doevents
        sleep %timedelay
        '''''''''''''''''''''''''''' change font
        incr fontsdisp&
        'undrln& = not undrln&
        bold& = not bold&
        ital& = not ital&
        fnteng_set gtfont, hdlg, 20, "tahoma", fntsize&, bold&, ital&, undrln&, 1, %green, %blue
        control set text hdlg, 20, "tahoma" + str$(fntsize&)
        dialog doevents
        sleep %timedelay
        '''''''''''''''''''''''''''' change font
        incr fontsdisp&
        undrln& = not undrln&
        bold& = not bold&
        'ital& = not ital&
        fnteng_set gtfont, hdlg, 20, "verdana", fntsize&, bold&, ital&, undrln&, 0, %blue, %green
        control set text hdlg, 20, "verdana" + str$(fntsize&)
        dialog doevents
        sleep %timedelay
        '''''''''''''''''''''''''''' change font
        incr fontsdisp&
        undrln& = not undrln&
        bold& = not bold&
        ital& = not ital&
        fnteng_set gtfont, hdlg, 20, "comic sans ms", fntsize&, bold&, ital&, undrln&, 0, %yellow, %blue
        control set text hdlg, 20, "comic sans ms" + str$(fntsize&)
        dialog doevents
        sleep %timedelay
        '''''''''''''''''''''''''''' change font
        incr fontsdisp&
        'undrln& = not undrln&
        bold& = not bold&
        ital& = not ital&
        fnteng_set gtfont, hdlg, 20, "microsoft sans serif", fntsize&, bold&, ital&, undrln&, 0, %blue, %green
        control set text hdlg, 20, "microsoft sans serif" + str$(fntsize&)
        dialog doevents
        sleep %timedelay
        '''''''''''''''''''''''''''' change font
        incr fontsdisp&
        undrln& = not undrln&
       ' bold& = not bold&
        ital& = not ital&
        fnteng_set gtfont, hdlg, 20, "times new roman", fntsize&, bold&, ital&, undrln&, 0, %magenta, %blue
        control set text hdlg, 20, "times new roman" + str$(fntsize&)
        dialog doevents
        sleep %timedelay
        '''''''''''''''''''''''''''' change font
        incr fontsdisp&
        undrln& = not undrln&
        bold& = not bold&
        'ital& = not ital&
        fnteng_set gtfont, hdlg, 20, "courier new", fntsize&, bold&, ital&, undrln&, 0, %red, %green
        control set text hdlg, 20, "courier new" + str$(fntsize&)
        control set text hdlg, 30, "fonts loaded:" + str$(fnteng_count(gtfont))
        control set text hdlg, 40, "fonts displayed:" + str$(fontsdisp&)
        dialog doevents
        sleep %timedelay
    next i
end function
' --------------------------------------------------
' --------------------------------------------------
sub fnteng_set( gtfont as fontenginetype, hdlg&, id&, fontname$, fontsize&, fontbold&, fontitalic&, fontunderline&, fontstrikeout&, optional fgcolor&, optional bgcolor& )
    local x as long
    local arry() as string : redim arry(1 to 6)
    local fontspec as string
    local hfont&

    arry(1) = fontname$
    arry(2) = ltrim$(str$(fontsize&))
    arry(3) = ltrim$(str$(fontbold&))
    arry(4) = ltrim$(str$(fontitalic&))
    arry(5) = ltrim$(str$(fontunderline&))
    arry(6) = ltrim$(str$(fontstrikeout&))
    fontspec = join$( arry(),",")

    if fnteng__aptrstrubound(byval gtfont.pafont)<1 then
        fnteng__aptrstrappend byval gtfont.pafont, fontspec
        hfont& = fnteng_makefont(fontspec)
        fnteng__aptrlongappend byval gtfont.pahandle, hfont&
    else
        x = fnteng__aptrstrscannc(byval gtfont.pafont, fontspec)
        if istrue x then
            hfont& = fnteng__aptrlongget(byval gtfont.pahandle, x)
        else
            fnteng__aptrstrappend byval gtfont.pafont, fontspec
            hfont& = fnteng_makefont(fontspec)
            fnteng__aptrlongappend byval gtfont.pahandle, hfont&
        end if
    end if

    control send hdlg&, id&, %wm_setfont, hfont&, 1

    if istrue varptr(fgcolor&) and istrue varptr(bgcolor&) then
        control set color hdlg&, id&, fgcolor&, bgcolor&
        control redraw hdlg&, id&
    end if
end sub
' --------------------------------------------------
' --------------------------------------------------
sub fnteng_wm_destroy( gtfont as fontenginetype )
    local i as long
    if fnteng__aptrstrubound(byval gtfont.pafont)>0 then
        for i=1 to fnteng__aptrstrubound(byval gtfont.pafont)
            deleteobject fnteng__aptrlongget(byval gtfont.pahandle, i)
        next i
    end if
end sub
' --------------------------------------------------
' --------------------------------------------------
function fnteng_count( gtfont as fontenginetype ) as long
    'number of fonts loaded
    function = fnteng__aptrstrubound(byval gtfont.pafont)
end function
' --------------------------------------------------
' --------------------------------------------------
function fnteng_makefont( fontspec$ ) as long
    local arry() as string : redim arry(1 to 6)
    local fontname$, fontsize&, fontbold&, fontitalic&, fontunderline&, fontstrikeout&
    local lffont as logfont, hdc as long, logpixelsy as long
    '
    ' modified from: erik christensen - grid.bas
    '
    parse fontspec$, arry()
    fontname$ = arry(1)
    fontsize& = val(arry(2))
    fontbold& = val(arry(3))
    fontitalic& = val(arry(4))
    fontunderline& = val(arry(5))
    fontstrikeout& = val(arry(6))
    '
    hdc = getdc(%hwnd_desktop)
    logpixelsy  = getdevicecaps(hdc, %logpixelsy)
    '
    releasedc %hwnd_desktop, hdc
    '
    lffont.lfheight = -muldiv(fontsize&,logpixelsy,72) '-(fonttypesize * logpixelsy) \ 72
                                                ' logical height of font
    lffont.lfwidth = 0                          ' logical average character width
    lffont.lfescapement = 0                     ' angle of escapement
    lffont.lforientation = 0                    ' base-line orientation angle
    lffont.lfweight = iif&(fontbold&, 700, 400) ' font weight
    lffont.lfitalic = fontitalic&               ' italic attribute flag (0,1)
    lffont.lfunderline = fontunderline&         ' underline attribute flag (0,1)
    lffont.lfstrikeout = fontstrikeout&         ' strikeout attribute flag (0,1)
    lffont.lfcharset = %ansi_charset            ' character set identifier
    lffont.lfoutprecision = %out_tt_precis      ' output precision
    lffont.lfclipprecision = %clip_default_precis  ' clipping precision
    lffont.lfquality = %default_quality         ' output quality
    lffont.lfpitchandfamily = %ff_dontcare      ' pitch and family
    lffont.lffacename = fontname$               ' typeface name string
    function = createfontindirect (lffont)
end function
' --------------------------------------------------
' --------------------------------------------------
function fnteng__aptrstrubound( byref arry() as string ) as long
    function = ubound( arry() )
end function
' --------------------------------------------------
' --------------------------------------------------
function fnteng__aptrstrscannc( byref arry() as string, byval thevalue as string ) as long
    local x as long
    array scan arry(), collate ucase, =ucase$(thevalue), to x
    function = x
end function
' --------------------------------------------------
' --------------------------------------------------
sub fnteng__aptrstrappend( byref arry() as string, byval thevalue as string )
    local x as long

    x = ubound(arry())
    incr x
    if x<1 then x=1
    redim preserve arry(1 to x)
    arry(x) = thevalue
end sub
' --------------------------------------------------
' --------------------------------------------------
function fnteng__aptrlongget( byref arry() as long, ndx& ) as long
    function = arry(ndx&)
end function
' --------------------------------------------------
' --------------------------------------------------
sub fnteng__aptrlongappend( byref arry() as long, byval thevalue as long )
    local x as long

    x = ubound(arry())
    incr x
    if x<1 then x=1
    redim preserve arry(1 to x)
    arry(x) = thevalue
end sub
' --------------------------------------------------

' ==================================================

------------------


[this message has been edited by stan durham (edited december 20, 2005).]

[Michael Mattias]

Interesting, but a little hard to pick one, isn't it? (Stop/back buttons might be nice).

Me, I wimped out when I wanted a program to view and select a font:

#COMPILE EXE
#DEBUG ERROR ON
#REGISTER NONE

#INCLUDE  "WIN32API.INC"    ' file date: 2/25/02 (PB version date).
#INCLUDE "COMDLG32.INC"
#RESOURCE "CHOOSE_FONT.PBR"


FUNCTION WINMAIN (BYVAL hInstance     AS LONG, _
                  BYVAL hPrevInstance AS LONG, _
                  BYVAL lpCmdLine     AS ASCIIZ PTR, _
                  BYVAL iCmdShow      AS LONG) AS LONG
  ' and the incredibly complicated code for what WinMain does:
  LOCAL cf AS choosefontapi       ' comdlg32
  cf.lstructSize  = SIZEOF(cf)
  cf.flags        = %CF_BOTH OR %CF_EFFECTS
  FUNCTION = ChooseFont(cf)

  FUNCTION = 5


END FUNCTION

[SG Dunn]

Mike -
- Question: What is "Choose_Font.PBR"?

------------------

[Michael Mattias]

Choose_font.pbr is the program's resource file. See in help file.

in this case, all it is the icon :

//  Choose_font.rc
#include "resource.h"
PROGRAM ICON icon01.ico

[Gösta H. Lovgren-2]

Very nice code, Mike. But for the life of me I can't figure out to retrieve the font info though. {arrgh!} Turning a Ptr into a string I'd guess is where I'm wrong.

'
'Michael Matthias via Poffs  

'Type CHOOSEFONTAPI
'    lStructSize    As Dword
'    hWndOwner      As Dword
'    hDC            As Dword
'    lpLogFont      As LOGFONT Ptr
'    iPointSize     As Long
'    Flags          As Dword
'    rgbColors      As Dword
'    lCustData      As Long
'    lpfnHook       As Dword
'    lpTemplateName As Asciiz Ptr
'    hInstance      As Dword
'    lpszStyle      As Asciiz Ptr
'    nFontType      As Word
'    Alignment      As Word
'    nSizeMin       As Long
'    nSizeMax       As Long
'End Type
'
'TYPE LOGFONT
'  lfHeight As Long
'  lfWidth As Long
'  lfEscapement As Long
'  lfOrientation As Long
'  lfWeight As Long
'  lfItalic As Byte
'  lfUnderline As Byte
'  lfStrikeOut As Byte
'  lfCharSet As Byte
'  lfOutPrecision As Byte
'  lfClipPrecision As Byte
'  lfQuality As Byte
'  lfPitchAndFamily As Byte
'  lfFaceName As Asciiz * %LF_FACESIZE
'End Type
'
Function Font_Choose 
  common_Locals
  Local cf As choosefontapi       ' comdlg32
  cf.lstructSize  = SizeOf(cf)
  cf.flags        = %CF_BOTH Or %CF_EFFECTS
  Function = ChooseFont(cf)
'  m1$ =cf.lpLogFont.lffaceName 'Only 1 of MANY efforts
'  mb
End Function

[Michael Mattias]

Function Font_Choose 
  common_Locals
  Local cf As choosefontapi       ' comdlg32
  cf.lstructSize  = SizeOf(cf)
  cf.flags        = %CF_BOTH Or %CF_EFFECTS
  Function = ChooseFont(cf)
ADDME: 
   Item =  cf.@lplogfont.desiredmember
   .......

[Gösta H. Lovgren-2]

Thanks Mike. Unfortunately it still doesn't work.

  m1$ = cf.@lplogfont.lfFaceName   '<<- GPF's
       'cf.@lplogfont.desiredmember

==============================
Hide not your talents,
they for use were made.
What's a sundial in the shade?
Ben Franklin
==============================

[Dave Biggs]

Gösta, this seems to work..

 
 Local cf As ChooseFontApi       ' comdlg32
 Local lf As LogFont
  cf.lstructSize  = SIZEOF(cf)
  cf.flags        = %CF_BOTH OR %CF_EFFECTS
  cf.lpLogFont    = VARPTR(lf)
  ChooseFont(cf)
 
  MsgBox lf.lfFaceName

[Gösta H. Lovgren-2]

As posted code uses SetWindowPos and may be displaying out of sight on Gösta's system? (Look for it in the taskbar).

I C&P'd the code MCM posted (Post 17) and it runs but doesn't show anything. (No Dialog created). (Icon on taskbar okay but does nothing. Have use Task Mgr to close it.)

Ideed the code does work (quite nifty I thought )

I wouldn't doubt it. However I don't see how it would fit into my existing dialog. Maybe if I fool with it some ... (Create another dialog I guess and pass a starting position to it.)

===============================================
It is dangerous to be right in matters
on which the established authorities are wrong.
~ Voltaire
===============================================

[Dave Biggs]

Gösta, If your screen resolution is 800 x 600 the ChooseFont window will be off the bottom of your screen. Change your screen res to 1024 x 768 and it'll be visible. Better yet change the code to..

SetWindowPos  hWnd, %HWND_TOP, 200, 200, %NULL, %NULL, %SWP_NOSIZE

(BTW If you can see the icon in the taskbar you could right-click / Close it without needing to resort to the Task Manager).

Thing is, calling ChooseFont() with the flag %CF_ENABLEHOOK set, tells the function to pass it's dialog messages through a callback procedure that we nominate, before the Default Proc does it's thing.
Once we have access to the messages for the ChooseFont dialog (that are normally happening behind the scenes) we can do things like set the position upon the %WM_INITDIALOG msg being received. (Returning '0' tells the Deafult Proc that message has been handled already).

No need to create an extra dialog - just get to grips with the one created by ChooseFont().

HTH

[Gösta H. Lovgren-2]

Thanks Dave. I do use 800x600. I will follow up with your suggestions today. What I am doing is completely rewriting in PB9 a database program that was the first progam I wrote in PBWin(6?) when I started with it some years ago when I didn't have the (compleat?) grasp of the windows concept I have today {he said tongue in cheek}.

Never thought about right clicking the icon. Just natural for me to ACD the task mgr. Have to do it so often when programming, you know. {grin}.

Ah'll be bock!

=================================
"Research is what I'm doing when
I don't know what I'm doing."
Wernher Von Braun (1912-1977)
=================================

[Michael Mattias]

I guess I should have left in the "CenterWindow" instead of the "SetWindowPos," huh?

I tested both and just left the last version I tested.

I tested the SetWindowPos because when I tested the CenterWindow, it looked pretty close to what I got with no hook and I wanted to be sure it worked, lest I cause any confusion. Well, I guess that didn't work out quite the way I expected....

[Gösta H. Lovgren-2]

Okay, Thanks to Dave's guidance and Mike's clever code, everything is working hunky dory.

I used Globals for positioning as I'm not comfortable enough with WinApi to pass variables on my own. I suppose I might be able use something in the LogFont or ChooseFontApi but for now, the Globals are fine.

Thanks Mike & Dave for a nifty routine.

Here's the routine. With only minimal adaption, most any PB'er should be able to just C&P it into his own code.

'Michael Matthias via Poffs  
'http://www.powerbasic.com/support/pbforums/showthread.php?p=294981#post294981
'
'Send these values for current Font and set g_Font_Col & g_Font_Row to where
'you want the Font Control to display on your dialog
Function Font_Choose(Font_Name$, Font_Size&, Font_Weight&) As Long
  Common_Locals 'my locals - just rem
 
 Local cf As ChooseFontApi       ' comdlg32 
 Local lf As LogFont
   cf.lstructSize  = SizeOf(cf)
   cf.flags        = %CF_EFFECTS Or _
                     %CF_SCREENFONTS Or _ 'screen fonts only
                     %CF_INITTOLOGFONTSTRUCT 'to use to pass values
 
  ' -----  to enable the hook procedure--------------
  cf.flags        = cf.flags Or %CF_ENABLEHOOK 'add hook to flags
  cf.lpfnhook    = CodePtr(CfHookProc)
  ' -------------------------------------------------  
 
  Local hDC As Long 'ala Dave Biggs
  Local CyPixels As Long 
    hDC = GetDC(%HWND_DESKTOP)
     CyPixels  = GetDeviceCaps(hDC, %LOGPIXELSY)
     ReleaseDC %HWND_DESKTOP, hDC
     Font_Size& = 0 - (Font_Size& * CyPixels) / 72 'to send to font control display
 
 
    'For display in Font Control
   If Font_Weight& = 0 Then 
      Font_Weight& = 400 'normal
     Else
      Font_Weight& = 700 'bold
   End If   
 
  'send to initialize
   cf.lpLogFont    = VarPtr(lf) 'to pass values
   lf.lfFaceName = Trim$(Font_Name$) & $Nul 'Works
   lf.lfWeight = Font_Weight& 
   lf.lfHeight = Font_Size&
 
   Function = ChooseFont(cf)   'call Font Control
 
   'Returned values
   Font_Name$ = lf.lfFaceName  
   Font_Size& = cf.iPointSize / 10'seems to work
   Font_Weight& = lf.lfWeight
 
      ' for PB Font use
   If Font_Weight& < 401 Then 
      Font_Weight& = 0 'normal
     Else
      Font_Weight& = 1 'bold
   End If   
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''
'Return Value
'If the hook procedure returns zero, the default dialog box procedure processes the message.
'If the hook procedure returns a nonzero value, the default dialog box procedure ignores the message.
Function  CfHookPRoc (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    '<<- g_Font_Col, g_Font_Row are set before calling this
    Select Case As Long   wMsg
         Case %WM_INITDIALOG
             'CALL CenterWindow (HWnd)    ' OK
              SetWindowPos  hWnd, %HWND_TOP, g_Font_Col, g_Font_Row, %Null, %Null, %SWP_NOSIZE   ' also OK
    End Select
 
    Function = 0  ' allow the rest of the default processing
 
End Function
 
 
Function CenterWindow Alias "CenterWindow" (ByVal hWnd As Long) Export As Long
   ' centers given Window on the desktop and forces to top
   Local rDW As RECT, rDlg As RECT
   GetClientRect GetDesktopWindow, Rdw
   GetWindowRect hWnd, rDlg
   SetWindowPos hWnd,_
        %HWND_TOP,_
       ((rDW.nright - rDW.nleft + 1) - (rDlg.nright - rDlg.nleft +1)) \2, _
       ((rDw.nBottom - rDW.nTop + 1) - (rDlg.nbottom - rDlg.nTop + 1)) \ 2, _
       0&,_
       0&, _
       %SWP_NOSIZE
End Function
'***************************************************
'***************************************************
'**********************************************************************