Home  |   French  |   About  |   Search  | mvps.org  

What's New
Table Of Contents
Credits
Netiquette
10 Commandments 
Bugs
Tables
Queries
Forms
Reports
Modules
APIs
Strings
Date/Time
General
Downloads
Resources
Search
Feedback
mvps.org

In Memoriam

Terms of Use


VB Petition

API: Calling Windows Choose Font Dialog

Author(s)
Terry Kreft
& Stephen Lebans

To call Windows ChooseFont dialog from code, we can use the ChooseFont API function.

Choose Font or Color Dialog.zip (Access 97)
' ******** Code Start ********
'This code was originally written by Terry Kreft,
'and modified by Stephen Lebans
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
' Contact Stephen@lebans.com
'
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)

Private Const LF_FACESIZE = 32

Private Const FW_BOLD = 700

Private Const CF_APPLY = &H200&
Private Const CF_ANSIONLY = &H400&
Private Const CF_TTONLY = &H40000
Private Const CF_EFFECTS = &H100&
Private Const CF_ENABLETEMPLATE = &H10&
Private Const CF_ENABLETEMPLATEHANDLE = &H20&
Private Const CF_FIXEDPITCHONLY = &H4000&
Private Const CF_FORCEFONTEXIST = &H10000
Private Const CF_INITTOLOGFONTSTRUCT = &H40&
Private Const CF_LIMITSIZE = &H2000&
Private Const CF_NOFACESEL = &H80000
Private Const CF_NOSCRIPTSEL = &H800000
Private Const CF_NOSTYLESEL = &H100000
Private Const CF_NOSIZESEL = &H200000
Private Const CF_NOSIMULATIONS = &H1000&
Private Const CF_NOVECTORFONTS = &H800&
Private Const CF_NOVERTFONTS = &H1000000
Private Const CF_OEMTEXT = 7
Private Const CF_PRINTERFONTS = &H2
Private Const CF_SCALABLEONLY = &H20000
Private Const CF_SCREENFONTS = &H1
Private Const CF_SCRIPTSONLY = CF_ANSIONLY
Private Const CF_SELECTSCRIPT = &H400000
Private Const CF_SHOWHELP = &H4&
Private Const CF_USESTYLE = &H80&
Private Const CF_WYSIWYG = &H8000
Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Private Const CF_NOOEMFONTS = CF_NOVECTORFONTS

Public Const LOGPIXELSY = 90

Public Type FormFontInfo
  Name As String
  Weight As Integer
  Height As Integer
  UnderLine As Boolean
  Italic As Boolean
  Color As Long
End Type

Private 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

Private Type FONTSTRUC
  lStructSize As Long
  hwnd 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 Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" _
(pChoosefont As FONTSTRUC) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" _
  (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GetDeviceCaps Lib "gdi32" _
  (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long


Private Function MulDiv(In1 As Long, In2 As Long, In3 As Long) As Long
Dim lngTemp As Long
  On Error GoTo MulDiv_err
  If In3 <> 0 Then
    lngTemp = In1 * In2
    lngTemp = lngTemp / In3
  Else
    lngTemp = -1
  End If
MulDiv_end:
  MulDiv = lngTemp
  Exit Function
MulDiv_err:
  lngTemp = -1
  Resume MulDiv_err
End Function
Private Function ByteToString(aBytes() As Byte) As String
  Dim dwBytePoint As Long, dwByteVal As Long, szOut As String
  dwBytePoint = LBound(aBytes)
  While dwBytePoint <= UBound(aBytes)
    dwByteVal = aBytes(dwBytePoint)
    If dwByteVal = 0 Then
      ByteToString = szOut
      Exit Function
    Else
      szOut = szOut & Chr$(dwByteVal)
    End If
    dwBytePoint = dwBytePoint + 1
  Wend
  ByteToString = szOut
End Function

Private Sub StringToByte(InString As String, ByteArray() As Byte)
Dim intLbound As Integer
  Dim intUbound As Integer
  Dim intLen As Integer
  Dim intX As Integer
  intLbound = LBound(ByteArray)
  intUbound = UBound(ByteArray)
  intLen = Len(InString)
  If intLen > intUbound - intLbound Then intLen = intUbound - intLbound
For intX = 1 To intLen
ByteArray(intX - 1 + intLbound) = Asc(Mid(InString, intX, 1))
Next
End Sub


Public Function DialogFont(ByRef f As FormFontInfo) As Boolean
  Dim LF As LOGFONT, FS As FONTSTRUC
  Dim lLogFontAddress As Long, lMemHandle As Long

  LF.lfWeight = f.Weight
  LF.lfItalic = f.Italic * -1
  LF.lfUnderline = f.UnderLine * -1
  LF.lfHeight = -MulDiv(CLng(f.Height), GetDeviceCaps(GetDC(hWndAccessApp), LOGPIXELSY), 72)
  Call StringToByte(f.Name, LF.lfFaceName())
  FS.rgbColors = f.Color
  FS.lStructSize = Len(FS)

  lMemHandle = GlobalAlloc(GHND, Len(LF))
  If lMemHandle = 0 Then
    DialogFont = False
    Exit Function
  End If

  lLogFontAddress = GlobalLock(lMemHandle)
  If lLogFontAddress = 0 Then
    DialogFont = False
    Exit Function
  End If

  CopyMemory ByVal lLogFontAddress, LF, Len(LF)
  FS.lpLogFont = lLogFontAddress
  FS.Flags = CF_SCREENFONTS Or CF_EFFECTS Or CF_INITTOLOGFONTSTRUCT
  If ChooseFont(FS) = 1 Then
    CopyMemory LF, ByVal lLogFontAddress, Len(LF)
    f.Weight = LF.lfWeight
    f.Italic = CBool(LF.lfItalic)
    f.UnderLine = CBool(LF.lfUnderline)
    f.Name = ByteToString(LF.lfFaceName())
    f.Height = CLng(FS.iPointSize / 10)
    f.Color = FS.rgbColors
    DialogFont = True
  Else
    DialogFont = False
  End If
End Function

Function test_DialogFont(ctl As Control) As Boolean
    Dim f As FormFontInfo
    With f
      .Color = 0
      .Height = 12
      .Weight = 700
      .Italic = False
      .UnderLine = False
      .Name = "Arial"
    End With
    Call DialogFont(f)
    With f
        Debug.Print "Font Name: "; .Name
        Debug.Print "Font Size: "; .Height
        Debug.Print "Font Weight: "; .Weight
        Debug.Print "Font Italics: "; .Italic
        Debug.Print "Font Underline: "; .UnderLine
        Debug.Print "Font COlor: "; .Color
        
        ctl.FontName = .Name
        ctl.FontSize = .Height
        ctl.FontWeight = .Weight
        ctl.FontItalic = .Italic
        ctl.FontUnderline = .UnderLine
        ctl = .Name & " - Size:" & .Height
    End With
    test_DialogFont = True
End Function
' ********* Code End ***********

1998-2010, Dev Ashish & Arvin Meyer, All rights reserved. Optimized for Microsoft Internet Explorer