| Prerequisites |
| None. |
|
 Finally,
here's the ultimate in user convenience ... not only do you pre-populate
the control with the user's current font settings, but you can also
display an Apply button which allows you to use a callback to detect the
pressing of this button, whereby you can affect the user's selection
while the dialog is open. Once again this demo builds on the forms used
in the other demos. This demo requires the addition of a BAS module for
the callback routine, and the repositioning of a few declares and
routines from the form to the BAS module for use by the callback.
 |
|
| BAS
Module Code |
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Const WM_USER As Long = &H400
Public Const WM_CHOOSEFONT_GETLOGFONT As Long = (WM_USER + 1)
Public Const WM_CHOOSEFONT_APPLY As Long = (WM_USER + 2)
Private Const WM_INITDIALOG As Long = &H110
Private Const WM_COMMAND As Long = &H111
Public Const LOGPIXELSY As Long = 90
Private Const LF_FACESIZE As Long = 32
Public 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(LF_FACESIZE) As Byte
End Type
Public Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Public Function MulMul(arg1 As Long, arg2 As Long, arg3 As Long) As Integer
Dim tmp As Single
tmp = arg2 / arg3
tmp = arg1 / tmp
MulMul = CInt(tmp)
End Function
Public Function ChooseFontHookProc(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
Dim lf As LOGFONT
Dim sFontName As String
Select Case uMsg
Case WM_INITDIALOG
Case WM_COMMAND
Select Case lParam
Case WM_CHOOSEFONT_APPLY
'ask the dialog for the current LOGFONT data
Call SendMessage(hWnd, WM_CHOOSEFONT_GETLOGFONT, 0&, lf)
'using this data, update Picture1
'font properties. Note that the colour selected
'is returned when ChooseFont closes, not as part
'of the LOGFONT structure. If you need the colour
'for the Apply function, you'll have to find a way
'to get the current selection directly from the
'control
sFontName = StrConv(lf.lfFaceName, vbUnicode)
sFontName = Left$(sFontName, InStr(sFontName, Chr$(0)) - 1)
With Form1.Picture1
.Cls
.CurrentY = 40
.Font.Strikethrough = lf.lfStrikeOut
.Font.Underline = lf.lfUnderline
.Font.Charset = lf.lfCharSet
.Font.Italic = lf.lfItalic
.Font.Name = sFontName
.Font.Size = -MulMul(lf.lfHeight, GetDeviceCaps(Form1.hdc, LOGPIXELSY), 72)
.Font.Weight = lf.lfWeight
'.ForeColor = {TODO}
Form1.Picture1.Print sFontName
End With
Case Else
End Select
Case Else
End Select
End Function
|
|
|
| Form
Code |
|
| To a new project form add
(top to bottom): a picture box (Picture 1), thirteen check boxes (Check1
through Check13), and five text boxes (Text1, Text2, Text3 for the RGB
colours, Text4 and Text5 for the LOGFONT info). Also add a
command button (Command1). The frames are optional, and the form
load code will label the controls for you. With this done, add the
following code to the form: |
|
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const CF_APPLY As Long = &H200&
Private Const CF_EFFECTS As Long = &H100&
Private Const CF_FIXEDPITCHONLY As Long = &H4000&
Private Const CF_INITTOLOGFONTSTRUCT As Long = &H40&
Private Const CF_NOVECTORFONTS As Long = &H800&
Private Const CF_PRINTERFONTS As Long = &H2
Private Const CF_SCREENFONTS As Long = &H1
Private Const CF_TTONLY As Long = &H40000
Private Const CF_ENABLEHOOK As Long = &H8&
Private Type ChooseFontType
lStructSize As Long
hwndOwner As Long
hdc As Long
lpLogFont As Long
iPointSize As Long
flags As Long
rgbColors As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
hInstance As Long
lpszStyle As String
nFontType As Integer
MISSING_ALIGNMENT As Integer
nSizeMin As Long
nSizeMax As Long
End Type
Private Type OurFontOptions
UseApply As Boolean
UseCallback As Boolean
UseEffects As Boolean
UseFixedPitchOnly As Boolean
UseLogFont As Boolean
UseNoVectorFonts As Boolean
UsePrinterFonts As Boolean
UseScreenFonts As Boolean
UseTrueTypeOnly As Boolean
SetFontName As String
SetFontSize As Long
SetFontBold As Boolean
SetFontItalic As Boolean
SetFontUnderline As Boolean
SetFontStrikeOut As Boolean
SetFontColour As Long
SetFontWeight As Long
End Type
Private Declare Function ChooseFont Lib "comdlg32.dll" _
Alias "ChooseFontA" _
(pChoosefont As ChooseFontType) As Long
Private Sub Form_Load()
Check1.Caption = "Printer Fonts"
Check2.Caption = "Screen Fonts"
Check3.Caption = "Fixed Pitch Only"
Check4.Caption = "No Vector Fonts"
Check5.Caption = "TrueType Only"
Check6.Caption = "Use Effects"
Check7.Caption = "Use LOGFONT Data"
Check8.Caption = "Italic"
Check9.Caption = "Bold"
Check10.Caption = "Strikeout"
Check11.Caption = "Underline"
Check12.Caption = "Use Callback"
Check13.Caption = "Use Apply"
'can't do Apply unless the callback is active
Check13.Enabled = Check12.Value = vbChecked
Text1.Text = "0"
Text2.Text = "128"
Text3.Text = "0"
Text4.Text = "20"
Text5.Text = "Times New Roman"
Command1.Caption = "Show Fonts"
Picture1.AutoRedraw = True
Picture1.Print "Sample Text"
End Sub
Private Sub Command1_Click()
Dim ofo As OurFontOptions
'populate our user-defined type with various
'font attributes used to initialize the dialog.
'Most are simple Boolean values indicating
'whether a particular check box on the form
'is checked or not.
With ofo
.UsePrinterFonts = Check1.Value = vbChecked
.UseScreenFonts = Check2.Value = vbChecked
.UseFixedPitchOnly = Check3.Value = vbChecked
.UseNoVectorFonts = Check4.Value = vbChecked
.UseTrueTypeOnly = Check5.Value = vbChecked
.UseEffects = Check6.Value = vbChecked
.UseLogFont = Check7.Value = vbChecked
.UseCallback = Check12.Value = vbChecked
.UseApply = Check13.Value = vbChecked
'this is used to select the colour of the
'font colour box. Note that only some values
'are valid; an colour combination that does
'not map directly to a font colour available
'causes the colour combo to select Black.
.SetFontColour = RGB(Val(Text1.Text), Val(Text2.Text), Val(Text3.Text))
'the rest of the attributes
.SetFontItalic = Check8.Value = 1
.SetFontBold = Check9.Value = 1
.SetFontStrikeOut = Check10.Value = 1
.SetFontUnderline = Check11.Value = 1
.SetFontName = Text5.Text
.SetFontSize = Val(Text4.Text)
End With
If GetFontSelection(ofo) Then
'update the controls to reflect
'the font and font attributes selected
Text4.Text = ofo.SetFontSize
Text5.Text = ofo.SetFontName
Check8.Value = Abs(ofo.SetFontItalic)
Check9.Value = Abs(ofo.SetFontBold)
Check10.Value = Abs(ofo.SetFontStrikeOut)
Check11.Value = Abs(ofo.SetFontUnderline)
'and update the picture box
With Picture1
.Cls
.CurrentY = 40
.Font.Strikethrough = ofo.SetFontStrikeOut
.Font.Underline = ofo.SetFontUnderline
.Font.Italic = ofo.SetFontItalic
.Font.Name = ofo.SetFontName
.Font.Size = ofo.SetFontSize
.Font.Weight = ofo.SetFontWeight
.ForeColor = ofo.SetFontColour
Picture1.Print ofo.SetFontName
End With
End If
End Sub
Private Sub Check12_Click()
'can't do Apply unless the callback is active
Check13.Enabled = Check12.Value = vbChecked
End Sub
Private Function FarProc(lpAddress As Long) As Long
FarProc = lpAddress
End Function
Private Function GetFontSelection(ofo As OurFontOptions) As Boolean
Dim cft As ChooseFontType
Dim lf As LOGFONT
Dim sFontName As String
'initialize the LOGFONT structure elements.
'convert a font name into a byte array
Call StrToByteArray(ofo.SetFontName, lf)
With lf
'convert the point size to logical units
'and assign the weight
.lfHeight = MulDiv(ofo.SetFontSize, GetDeviceCaps(hdc, LOGPIXELSY), 72)
.lfWeight = IIf(ofo.SetFontBold, 700, 400)
.lfItalic = ofo.SetFontItalic
'style box parameters
.lfStrikeOut = ofo.SetFontStrikeOut
.lfUnderline = ofo.SetFontUnderline
End With 'lf
'define required ChooseFont structure elements
With cft
'pointer to the logfont structure set above
.lpLogFont = VarPtr(lf)
'this form is the owner
.lStructSize = LenB(cft)
.hwndOwner = Me.hWnd
.hdc = Me.hdc
'the font colour - if 0 will default to black
.rgbColors = ofo.SetFontColour
'display/options flags
If ofo.UseApply Then .flags = (.flags & CF_APPLY)
If ofo.UseEffects Then .flags = (.flags Or CF_EFFECTS)
If ofo.UseLogFont Then .flags = (.flags Or CF_INITTOLOGFONTSTRUCT)
If ofo.UseFixedPitchOnly Then .flags = (.flags Or CF_FIXEDPITCHONLY)
If ofo.UseNoVectorFonts Then .flags = (.flags Or CF_NOVECTORFONTS)
If ofo.UsePrinterFonts Then .flags = (.flags Or CF_PRINTERFONTS)
If ofo.UseScreenFonts Then .flags = (.flags Or CF_SCREENFONTS)
If ofo.UseTrueTypeOnly Then .flags = (.flags Or CF_TTONLY)
'the callback routine
If ofo.UseCallback Then
cft.flags = (.flags Or CF_ENABLEHOOK)
cft.lpfnHook = FarProc(AddressOf ChooseFontHookProc)
End If
End With 'cft
'display font common dialog
If ChooseFont(cft) Then
'retrieve values for selected font
sFontName = StrConv(lf.lfFaceName, vbUnicode)
sFontName = Left$(sFontName, InStr(sFontName, Chr$(0)) - 1)
ofo.SetFontBold = lf.lfWeight > 400
ofo.SetFontColour = cft.rgbColors
ofo.SetFontName = sFontName
ofo.SetFontSize = -MulMul(lf.lfHeight, GetDeviceCaps(hdc, LOGPIXELSY), 72)
ofo.SetFontItalic = lf.lfItalic
ofo.SetFontStrikeOut = lf.lfStrikeOut
ofo.SetFontUnderline = lf.lfUnderline
ofo.SetFontWeight = lf.lfWeight
GetFontSelection = True
End If
End Function
Private Function MulDiv(arg1 As Long, arg2 As Long, arg3 As Long) As Single
Dim tmp As Single
tmp = arg2 / arg3
tmp = arg1 * tmp
MulDiv = tmp
End Function
Private Function StrToByteArray(sFont As String, lf As LOGFONT) As Long
Dim cnt As Long
Dim max As Long
max = Len(sFont)
If max > 0 Then
For cnt = 0 To max - 1
lf.lfFaceName(cnt) = Asc(Mid$(sFont, cnt + 1, 1))
Next
StrToByteArray = max > 0
End If
End Function
|
|
| Comments |
|
The same caveats apply to this demo as with the basic demo: If
you pass a colour value not supported by the font combo, the font combo
will revert to Black. Also, pressing OK without selecting a font is not
the same as pressing cancel; the return value of the call is non-0 and
the subsequent code in the If condition will execute.
|
|
