'
Code:
'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
'***************************************************
'***************************************************
'**********************************************************************
'