Binaryworld - Show ChooseFont dialogbox using API ... [ VB -> Dialogbox ]

You can use ChooseFont API to show Font selection common dialogbox. This API will eliminate the need of Common Dialog ActiveX control which comes with Visual Basic.

Step-By-Step Example

- Create a standard exe project
- Add one commandbutton on the form1
- Add the following code in form1

Note: You can not use StdFont if you have not referenced "OLE Automation" library in Project reference dialogbox

Click here to copy the following block

Private Declare Function ChooseFont Lib "COMDLG32" Alias "ChooseFontA" ( _
    pCHOOSEFONT As TCHOOSEFONT) As Long

Private Declare Function CommDlgExtendedError Lib "COMDLG32.DLL" () As Long

Private Declare Sub CopyMemoryStr Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, _
    ByVal lpvSource As String, _
    ByVal cbCopy As Long)

Private m_Font As New StdFont

Private Const LF_FACESIZE = 32

Public Enum EChooseFont
  CF_SCREENFONTS = &H1
  CF_PRINTERFONTS = &H2
  CF_BOTH = &H3
  CF_FONTSHOWHELP = &H4
  CF_USESTYLE = &H80
  CF_EFFECTS = &H100
  CF_ANSIONLY = &H400
  CF_NOVECTORFONTS = &H800
  CF_NOOEMFONTS = &H800
  CF_NOSIMULATIONS = &H1000
  CF_LIMITSIZE = &H2000
  CF_FIXEDPITCHONLY = &H4000
  CF_WYSIWYG = &H8000
  CF_FORCEFONTEXIST = &H10000
  CF_SCALABLEONLY = &H20000
  CF_TTONLY = &H40000
  CF_NOFACESEL = &H80000
  CF_NOSTYLESEL = &H100000
  CF_NOSIZESEL = &H200000
  CF_SELECTSCRIPT = &H400000
  CF_NOSCRIPTSEL = &H800000
  CF_NOVERTFONTS = &H1000000
  CF_INITTOLOGFONTSTRUCT = &H40
  CF_APPLY = &H200
  CF_ENABLEHOOK = &H8
  CF_ENABLETEMPLATE = &H10
  CF_ENABLETEMPLATEHANDLE = &H20
End Enum

Public Enum EFontType
  SIMULATED_FONTTYPE = &H8000
  PRINTER_FONTTYPE = &H4000
  SCREEN_FONTTYPE = &H2000
  BOLD_FONTTYPE = &H100
  ITALIC_FONTTYPE = &H200
  REGULAR_FONTTYPE = &H400
End Enum

Public Enum EDialogError
  CDERR_DIALOGFAILURE = &HFFFF
  CDERR_GENERALCODES = &H0&
  CDERR_STRUCTSIZE = &H1&
  CDERR_INITIALIZATION = &H2&
  CDERR_NOTEMPLATE = &H3&
  CDERR_NOHINSTANCE = &H4&
  CDERR_LOADSTRFAILURE = &H5&
  CDERR_FINDRESFAILURE = &H6&
  CDERR_LOADRESFAILURE = &H7&
  CDERR_LOCKRESFAILURE = &H8&
  CDERR_MEMALLOCFAILURE = &H9&
  CDERR_MEMLOCKFAILURE = &HA&
  CDERR_NOHOOK = &HB&
  CDERR_REGISTERMSGFAIL = &HC&
  CFERR_CHOOSEFONTCODES = &H2000&
  CFERR_NOFONTS = &H2001&
  CFERR_MAXLESSTHANMIN = &H2002&
  FNERR_FILENAMECODES = &H3000&
  FNERR_SUBCLASSFAILURE = &H3001&
  FNERR_INVALIDFILENAME = &H3002&
  FNERR_BUFFERTOOSMALL = &H3003&
  CCERR_CHOOSECOLORCODES = &H5000&
End Enum

Private Type TCHOOSEFONT
  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 Long
  hInstance As Long
  lpszStyle As String
  nFontType As Integer
  iAlign As Integer
  nSizeMin As Long
  nSizeMax 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

Public Function ShowFont() As Boolean
  Dim PrinterDC As Long
  Dim L As Long

  Err.Clear  '//Clear any previous error

  '//Unwanted m_flags bits as we don't support them
  Const CF_FontNotSupported = CF_APPLY Or CF_ENABLEHOOK Or CF_ENABLETEMPLATE

  '//m_flags can get reference variable or constant with bit m_flags

  '//Set the hdc for the printer if printerfonts are being used
  If m_flags And CF_PRINTERFONTS Then PrinterDC = Printer.hdc

  '//Must have some fonts
  If (m_flags And CF_PRINTERFONTS) = 0 Then m_flags = m_flags Or CF_SCREENFONTS

  '//check to see if there was a color selected
  If m_FontColor > 0 Then m_flags = m_flags Or CF_EFFECTS

  '//check to see if there were minimum or maximum sizes
  If m_FontMinSize > 0 Or m_FontMaxSize > 0 Then m_flags = m_flags Or CF_LIMITSIZE

  '//Put in required internal m_flags and remove unsupported
  m_flags = (m_flags Or CF_INITTOLOGFONTSTRUCT) And Not CF_FontNotSupported

  '//Initialize LOGFONT variable
  Dim LogFnt As LOGFONT
  Const PointsPerTwip = 1440 / 72
  LogFnt.lfHeight = -(m_Font.Size * (PointsPerTwip / Screen.TwipsPerPixelY))
  LogFnt.lfWeight = m_Font.Weight
  LogFnt.lfItalic = m_Font.Italic
  LogFnt.lfUnderline = m_Font.Underline
  LogFnt.lfStrikeOut = m_Font.Strikethrough

  '//Other fields zero
  StrToByteArray LogFnt.lfFaceName, m_Font.Name

  '//Initialize TCHOOSEFONT variable
  Dim ChooseFnt As TCHOOSEFONT
  With ChooseFnt
    .lStructSize = Len(ChooseFnt)
    .hWndOwner = m_hWnd
    .hdc = PrinterDC
    .lpLogFont = VarPtr(LogFnt)
    .iPointSize = m_Font.Size * 10
    .Flags = m_flags
    .rgbColors = Color
    .nSizeMin = m_FontMinSize
    .nSizeMax = m_FontMaxSize
  End With

  '//Call the dialog box
  L = ChooseFont(ChooseFnt)
  Select Case L
    Case 1
      '//Success
      m_flags = ChooseFnt.Flags
      m_FontColor = ChooseFnt.rgbColors
      m_Font.Bold = ChooseFnt.nFontType And BOLD_FONTTYPE
      m_Font.Italic = LogFnt.lfItalic
      m_Font.Strikethrough = LogFnt.lfStrikeOut
      m_Font.Underline = LogFnt.lfUnderline
      m_Font.Weight = LogFnt.lfWeight
      m_Font.Size = ChooseFnt.iPointSize / 10
      m_Font.Name = StrConv(LogFnt.lfFaceName, vbUnicode)
      ShowFont = True
    Case 0
      '//canceled
      'If m_CancelError Then Err.Raise 1001, "Run-time error", "Cancel was selected"
      ShowFont = False
      Err.Number = 1001
    Case Else
      '//Extended error
      m_ExtendedErr = CommDlgExtendedError()
      '//Err.Raise m_ExtendedErr
      Err.Number = CommDlgExtendedError
      ShowFont = False
  End Select

End Function

Private Function IsArrayEmpty(va As Variant) As Boolean
  Dim v As Variant
  On Error Resume Next
  v = va(LBound(va))
  IsArrayEmpty = (Err <> 0)
End Function

Private Sub StrToByteArray(ab() As Byte, s As String)
  If IsArrayEmpty(ab) Then
    ' Assign to empty array
    ab = StrConv(s, vbFromUnicode)
  Else
    Dim cab As Long
    ' Copy to existing array, padding or truncating if necessary
    cab = UBound(ab) - LBound(ab) + 1
    If Len(s) < cab Then s = s & String$(cab - Len(s), 0)
    CopyMemoryStr ab(LBound(ab)), s, cab
  End If
End Sub

Private Sub Command1_Click()
  Dim ret As Boolean, strMsg As String
  ret = ShowFont
  If ret = True Then
    strMsg = "Name:" & m_Font.Name & vbCrLf & _
        "Bold:" & m_Font.Bold & vbCrLf & _
        "Charset:" & m_Font.Charset & vbCrLf & _
        "Italic:" & m_Font.Italic & vbCrLf & _
        "Size:" & m_Font.Size & vbCrLf & _
        "Underline:" & m_Font.Underline & vbCrLf
    MsgBox strMsg
  Else
    MsgBox "Error #" & Err.Number
  End If

End Sub