Choose a Font

[Gösta H. Lovgren-2]

Here's an Include for Choosing/Setting fonts some may find useful

'

 
'Example call -
   'ans = Font_Choose(fn$, fnum, fnum1, Row, Col)
   '  If ans = 1 Then 'font change made
   '     'Do stuff here       
   '  end if

'***************************************************
'****** Choose Font ********************************
'***************************************************
'
'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         'size?
'    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
'End Type
'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 Dialog to display
'Example call -
   'ans = Font_Choose(fn$, fnum, fnum1, Row, Col)
   '  If ans = 1 Then 'font change made
   '
Function Font_Choose(Font_Name$, Font_Size&, Font_Weight&, Font_Row&, Font_Col&) As Long
'
 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(Font_CfHookPRoc)
 ' --- to use available 'lparam' to hold desired row and column ----
  ' since neither value will exceed 65536, we'll just pack this info
  ' into the available (LONG) integer                         
  cf.lCustData   =  MakLng(FONT_COL&, FONT_ROW&) 
   'try this myself
  cf.nSizeMin = Font_Col&
  cf.nSizeMax  = Font_Row&
  ' -------------------------------------------------  
'
  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
 '
    '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 Dialog
'   
   '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  Font_CfHookPRoc (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Local pCF   As ChooseFontAPI Ptr, iRow As Long, iCol As Long
'
    Select Case As Long   wMsg
         Case %WM_INITDIALOG
             pCF    = lparam     ' on WM_INITDIALOG, lparam is PTR to CHOOSEFONT structure
                                 ' with which the ChoosefFont() function was called
             'iRow = LoWrd(@pCF.lcustdata)   ' unpack row and column....
             'iCol = HiWrd(@pCF.lcustdata)
              'my Try
             iRow = @Pcf.nSizeMin 
             iCol = @Pcf.nSizeMax
 '
            Local pI As Integer Ptr 
              pCF = lparam
              pI  = VarPtr (@pCF.lcustdata) 
              iRow = @pi
              Incr  pI 
              iCol = @pI
  '           
              SetWindowPos  hWnd, %HWND_TOP, iRow, icol, %Null, %Null, %SWP_NOSIZE   ' also OK
    End Select
'    
    Function = 0  ' allow the rest of the default processing
'    
End Function
'
'
Function Font_Center_Dialog Alias "Font_Center_Dialog" (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
'***************************************************
'***************************************************
'**********************************************************************
'