Custom control limits size so cannot select value

Option Explicit
 
' From Access 2000 Developer's Handbook, Volume I
' by Getz, Litwin, and Gilbert. (Sybex)
' Copyright 1999. All rights reserved.
'
' Provide access to the File Open/Save,
' Color and Font common dialogs.
' Works similarly to the CommonDialog
' ActiveX control, but adds more features,
' and doesn't implement Printer or Help
' support.
 
' NOTE: This class module contains
' some redundant code (that is, code
' copied from other modules) so that
' it can be imported and used in other
' applications without needing to
' also import any subsidiary modules.
 
' =================
' API Constants
' =================
Private Const HWND_DESKTOP = 0
Private Const LF_FACESIZE = 32
Private Const FNERR_BUFFERTOOSMALL = &H3003
 
' Modify the Open/Save dialog box.
Private Const WM_USER = &H400
Private Const CDM_FIRST = (WM_USER + 100)
 
' =================
' API Enums (values defined by API,
' Enums defined here). These are set
' up to match the CommonDialog ActiveX
' control's constants, but we've added
' some extras.
' =================
 
Public Enum adhCDFontType
    RASTER_FONTTYPE = &H1
    DEVICE_FONTTYPE = &H2
    TRUETYPE_FONTTYPE = &H4
    BOLD_FONTTYPE = &H100
    ITALIC_FONTTYPE = &H200
    REGULAR_FONTTYPE = &H400
    SCREEN_FONTTYPE = &H2000
    PRINTER_FONTTYPE = &H4000
    SIMULATED_FONTTYPE = &H8000
    OPENTYPE_FONTTYPE = &H10000
    TYPE1_FONTTYPE = &H20000
    DSIG_FONTTYPE = &H40000
End Enum
 
Public Enum adhFontFaceAPI
    ANSI_CHARSET = 0
    DEFAULT_CHARSET = 1
    SYMBOL_CHARSET = 2
    SHIFTJIS_CHARSET = 128
    HANGEUL_CHARSET = 129
    GB2312_CHARSET = 134
    CHINESEBIG5_CHARSET = 136
    OEM_CHARSET = 255
    JOHAB_CHARSET = 130
    HEBREW_CHARSET = 177
    ARABIC_CHARSET = 178
    GREEK_CHARSET = 161
    TURKISH_CHARSET = 162
    VIETNAMESE_CHARSET = 163
    THAI_CHARSET = 222
    EASTEUROPE_CHARSET = 238
    RUSSIAN_CHARSET = 204
    MAC_CHARSET = 77
    BALTIC_CHARSET = 186
End Enum
 
Public Enum adhColorConstants
    cdlCCFullOpen = 2
    cdlCCHelpButton = 8
    cdlCCPreventFullOpen = 4
    cdlCCRGBInit = 1
    cdlCCAnyColor = &H100
    cdlCCEnableHook = &H10
    cdlCCSolidColor = &H80
End Enum
 
Public Enum adhErrorConstants
  '  cdlAlloc = 32752
    cdlAlloc = 45000
    cdlBufferTooSmall = 20476
   ' cdlCancel = 32755
   cdlCancel = 45000
    cdlCreateICFailure = 28661
    'Matches Number
    'cdlDialogFailure = -32768
      cdlDialogFailure = -45000
      cdlDndmMismatch = 28662
   '' cdlFindResFailure = 32761
    cdlFindResFailure = 45000
    cdlGetDevModeFail = 28666
    cdlGetNotSupported = 394
  ''  cdlHelp = 32751
  cdlHelp = 45000
    cdlInitFailure = 28665
    'cdlInitialization = 32765
    cdlInitialization = 45000
    cdlInvalidFileName = 20477
    cdlInvalidPropertyValue = 380
    cdlInvalidSafeModeProcCall = 680
    cdlLoadDrvFailure = 28667
   ' cdlLoadResFailure = 32760
   cdlLoadResFailure = 45000
  ''  cdlLoadStrFailure = 32762
  cdlLoadStrFailure = 45000
  ''  cdlLockResFailure = 32759
    cdlLockResFailure = 45000
  ''  cdlMemAllocFailure = 32758
  cdlMemAllocFailure = 45000
 '' cdlMemLockFailure = 32757
 cdlMemLockFailure = 45000
   cdlNoDefaultPrn = 28663
 cdlNoDevices = 28664
   cdlNoFonts = 24574
   ''cdlNoInstance = 32763
   cdlNoInstance = 45000
 '' cdlNoTemplate = 32764
  cdlNoTemplate = 45000
  cdlParseFailure = 28669
  cdlPrinterCodes = 28671
 cdlPrinterNotFound = 28660
    cdlRetDefFailure = 28668
   cdlSetNotSupported = 383
  cdlSetupFailure = 28670
  cdlSubclassFailure = 20478
 
End Enum
 
Public Enum adhFileOpenConstants
    cdlOFNAllowMultiselect = 512
    cdlOFNCreatePrompt = 8192
    cdlOFNEnableHook = 32
    cdlOFNEnableSizing = 8388608
    cdlOFNExplorer = 524288
    cdlOFNExtensionDifferent = 1024
    cdlOFNFileMustExist = 4096
    cdlOFNHelpButton = 16
    cdlOFNHideReadOnly = 4
    cdlOFNLongNames = 2097152
    cdlOFNNoChangeDir = 8
    cdlOFNNoDereferenceLinks = 1048576
    cdlOFNNoLongNames = 262144
    cdlOFNNoNetworkButton = 131072
    
   ' cdlOFNNoReadOnlyReturn = 32768
    cdlOFNNoReadOnlyReturn = 37500
    cdlOFNNoValidate = 256
    cdlOFNOverwritePrompt = 2
    cdlOFNPathMustExist = 2048
    cdlOFNReadOnly = 1
    cdlOFNShareAware = 16384
End Enum
 
Public Enum adhFontsConstants
    cdlCFANSIOnly = &H400
    cdlCFApply = &H200
    cdlCFBoth = &H3
    cdlCFEffects = &H100
    cdlCFEnableHook = &H8
    cdlCFFixedPitchOnly = &H4000
    cdlCFForceFontExist = &H10000
    cdlCFInitToLogFontStruct = &H40
    cdlCFLimitSize = &H2000
    cdlCFNoFaceSel = &H80000
    cdlCFNoSimulations = &H1000
    cdlCFNoSizeSel = &H200000
    cdlCFNoStyleSel = &H100000
    cdlCFNoVectorFonts = &H800
    cdlCFNoVertFonts = &H1000000
    cdlCFPrinterFonts = &H2
    cdlCFScalableOnly = &H20000
    cdlCFScreenFonts = &H1
    cdlCFShowHelp = &H4
    cdlCFTTOnly = &H40000
    cdlCFUseStyle = &H80
    cdlCFWYSIWYG = &H8000       ' must also have cdlCFScreenFonts & cdlCFPrinterFonts
End Enum
 
' You can use these values in the
' File Open/Save callback function
' to modify the text or visibility
' of any of the controls on the
' dialog. See the example callback
' function for a demo.
Public Enum adhFileOpenSaveControls
    fosCurrentFolder = &H471
    fosCurrentFolderLabel = &H443
    fosContentsList = &H460
    fosContentsListLabel = &H440
    fosSelectedFile = &H480
    fosSelectedFileLabel = &H442
    fosFilterList = &H470
    fosFilterListLabel = &H441
    fosReadOnly = &H410
    fosOKButton = 1
    fosCancelButton = 2
    fosHelpButton = &H40E
End Enum
 
Public Enum adhCommonDialogManage
    CDM_SETCONTROLTEXT = (CDM_FIRST + &H4)
    CDM_HIDECONTROL = (CDM_FIRST + &H5)
End Enum
 
' =================
' API Types
' =================
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(1 To LF_FACESIZE) As Byte
End Type
 
Private Type ChooseColor
    lStructSize As Long
    hWndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As Long
    Flags As adhColorConstants
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 
Private Type OPENFILENAME
    lStructSize As Long
    hWndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    Flags As adhFileOpenConstants
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 
Private Type ChooseFont
    lStructSize As Long
    hWndOwner As Long          '  caller's window handle
    hdc As Long                '  printer DC/IC or NULL
    lpLogFont As Long
    iPointSize As Long         '  10 * size in points of selected font
    Flags As adhFontsConstants    '  enum. type flags
    rgbColors As Long          '  returned text color
    lCustData As Long          '  data passed to hook fn.
    lpfnHook As Long           '  ptr. to hook function
    lpTemplateName As String   '  custom template name
    hInstance As Long          '  instance handle of.EXE that
                               '    contains cust. dlg. template
    lpszStyle As String        '  return the style field here
                               '  must be LF_FACESIZE or bigger
    nFontType As Integer       '  same value reported to the EnumFonts
                               '    call back with the extra FONTTYPE_
                               '    bits added
    MISSING_ALIGNMENT As Integer
    nSizeMin As Long           '  minimum pt size allowed &
    nSizeMax As Long           '  max pt size allowed if
                                   '    CF_LIMITSIZE is used
End Type
 
' =================
' API Declarations
' =================
Private Declare Function GetDC _
 Lib "USER32" _
 (ByVal hWnd As Long) As Long
 
Private Declare Function ReleaseDC _
 Lib "USER32" _
 (ByVal hWnd As Long, ByVal hdc As Long) As Long
 
Private Const LOGPIXELSY = 90
Private Declare Function GetDeviceCaps _
 Lib "gdi32" _
 (ByVal hdc As Long, ByVal nIndex As Long) As Long
 
Private Declare Function MulDiv _
 Lib "kernel32" _
 (ByVal nNumber As Long, ByVal nNumerator As Long, _
 ByVal nDenominator As Long) As Long
 
Private Declare Function CommDlgExtendedError _
 Lib "comdlg32.dll" () As Long
 
Private Declare Function ChooseFont _
 Lib "comdlg32.dll" Alias "ChooseFontA" _
 (pChoosefont As ChooseFont) As Long
 
Private Declare Function ChooseColor _
 Lib "comdlg32.dll" Alias "ChooseColorA" _
 (pChoosecolor As ChooseColor) As Long
 
Private Declare Function GetOpenFileName _
 Lib "comdlg32.dll" Alias "GetOpenFileNameA" _
 (pOpenfilename As OPENFILENAME) As Long
 
Private Declare Function GetSaveFileName _
 Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
 (pOpenfilename As OPENFILENAME) As Long
 
' =================
' Storage for property values.
' =================
 
' Returns/sets the size of the file name
' buffer to use for the FileOpen dialog box.
' The default size is 1000.
Public FileNameBufferSize As Long
 
' Returns/sets the custom file open/save filter.
' Public CustomFilter As String
 
' Returns/sets the default filename extension for the dialog box.
Public DefaultExt As String
 
' Sets the string displayed in the title bar of the dialog box.
Public DialogTitle As String
 
' Returns/sets the path and filename of a selected file.
Public FileName As String
 
 ' Returns/sets the name (without the path) of the file to open or save at run time.
 Public FileTitle As String
 
' Returns/sets the filters that are displayed in the Type list box of a dialog box.
Public Filter As String
 
' Returns/sets a default filter for an Open or Save As dialog box.
Public FilterIndex As Long
 
' Returns/sets the initial file directory.
Public InitDir As String
 
' Returns/sets the selected color.
Public Color As Long
 
' Sets the hWnd of the dialog owner.
Public hWndOwner As Long
 
' Sets/Returns the character set.
' Although interesting, doesn't correspond
' to any property in the host app.
Public FontScript As adhFontFaceAPI
 
' Text describing the selected font style.
Public FontStyle As String
 
' Set/Returns the minimum and maximum font sizes,
' if you've set the cdlCFLimitSize flag.
' Disregarded otherwise.
Public Min As Integer
Public Max As Integer
 
' Returns the selected font color.
Public FontColor As Long
 
' Flag settings (for backwards compatability only)
Public Flags As Long
 
' Flags specific to the specific dialog box.
Public FontFlags As adhFontsConstants
Public ColorFlags As adhColorConstants
Public OpenFlags As adhFileOpenConstants
 
' Address of the callback function.
Public CallBack As Long
 
' Specifies the name of the font that appears in each row for the given level.
Public FontName As String
 
' Indicates whether an error is generated when the user chooses the Cancel button.
Public CancelError As Boolean
 
' Returns/sets italic font styles.
Public FontItalic As Boolean
 
' Returns/sets bold font styles. Included for
' backwards compatability. Use FontWeight
' instead.
Public FontBold As Boolean
 
' Font weight, from 100 to 900 (in multiples of 100)
' 700 is bold, 400 is normal.
Public FontWeight As Long
 
' Specifies the size (in points) of the font that appears in each row for the given level.
Public FontSize As Single
 
' Returns/sets strikethrough font styles.
Public FontStrikeThrough As Boolean
 
' Returns/sets underline font styles.
Public FontUnderline As Boolean
 
' Retrieve the font type, from the adhCDFontType
' list of options. Can be any number of
' items from the group, OR'd together.
Private mlngFontType As adhCDFontType
 
' Retrieve the 16 user-defined colors
' returned from the color chooser dialog.
Private malngColors(0 To 15) As Long
 
' Retrieve the offset within the full file name
' to the file portion, or the extension portion.
Private mlngFileOffset As Long
Private mlngFileExtOffset As Long
 
' Retrieve the list of files selected
' if cdlOFNAllowMultiSelect flag
' is set. If not, this array contains
' only the path, and single file selected.
Private mastrFileList() As String
 
Public Property Get FileList() As String()
    ' Get the parsed list of files.
    ' If there are items in this list,
    ' the 0th element is the path, and the
    ' rest are the selected files.
    ' Even if you only select a single
    ' file, we populate this array.
    FileList = mastrFileList
End Property
 
Public Property Get FileOffset() As Long
    ' Returns the offset within the full file name
    ' to the file portion.
    FileOffset = mlngFileOffset
End Property
 
Public Property Get FileExtOffset() As Long
    ' Returns the offset within the full file name
    ' to the file portion.
    FileExtOffset = mlngFileExtOffset
End Property
 
Public Property Get CustomColors() As Long()
    ' Return the array of custom colors.
    CustomColors = malngColors
End Property
 
Public Property Let CustomColors(Value() As Long)
    Dim i As Integer
    
    ' The array passed in must be indexed from
    ' 0 to 15. If not, weird things are going
    ' to happen -- we just copy from those
    ' indexes directly over.
    On Error GoTo HandleErrors
    For i = 0 To 15
        malngColors(i) = Value(i)
NextValue:
    Next i
    
ExitHere:
    Exit Property
    
HandleErrors:
    Resume NextValue
End Property
 
Public Property Get FontType() As adhCDFontType
    FontType = mlngFontType
End Property
 
' =================
' CommonDlg Methods
' =================
Public Sub ShowColor()
    
    ' From Access 2000 Developer's Handbook, Volume I
    ' by Getz, Litwin, and Gilbert. (Sybex)
    ' Copyright 1999. All rights reserved.
    '
    ' Displays the CommonDialog control's Color dialog box.
    
    Dim cc As ChooseColor
    
    Call SetColorProperties(cc)
    If ChooseColor(cc) <> 0 Then
        Call GetColorProperties(cc)
    Else
        ' If the user wants to raise an error for the Escape
        ' do it now.
        If CancelError Then
            Err.Raise cdlCancel, , "Cancel was selected."
        End If
    End If
End Sub
 
Public Sub ShowFont()
    
    ' From Access 2000 Developer's Handbook, Volume I
    ' by Getz, Litwin, and Gilbert. (Sybex)
    ' Copyright 1999. All rights reserved.
    '
    ' Display the CommonDialog control's Font dialog box
    
    Dim cf As ChooseFont
    Dim lf As LOGFONT
    Dim strStyle As String
    
    ' Arbitrarily allow 100 characters
    ' for the style string.
    strStyle = Space(100)
    Call SetFontProperties(cf, lf, strStyle)
    If ChooseFont(cf) <> 0 Then
        ' The user pressed the OK button
        Call GetFontProperties(cf, lf)
    Else
        ' If the user wants to raise an error for the Escape
        ' do it now.
        If CancelError Then
            Err.Raise cdlCancel, , "Cancel was selected."
        End If
    End If
End Sub
 
Public Sub ShowOpen()
    
    ' From Access 2000 Developer's Handbook, Volume I
    ' by Getz, Litwin, and Gilbert. (Sybex)
    ' Copyright 1999. All rights reserved.
    '
    ' Displays the CommonDialog control's Open dialog box.
    
    Dim ofn As OPENFILENAME
    Dim lngErr As Long
    
    Call SetOpenProperties(ofn)
    If GetOpenFileName(ofn) <> 0 Then
        Call GetOpenProperties(ofn)
    Else
        lngErr = CommDlgExtendedError()
        Select Case lngErr
            Case FNERR_BUFFERTOOSMALL
                Err.Raise cdlBufferTooSmall, , _
                 "Filename buffer is too small for the selected files."
            Case 0
                ' If the user wants to raise an error for the Escape
                ' do it now.
                If CancelError Then
                    Err.Raise cdlCancel, , "Cancel was selected."
                End If
            Case Else
                Err.Raise lngErr, , "Unexpected error."
        End Select
    End If
End Sub
 
Public Sub ShowSave()
    
    ' From Access 2000 Developer's Handbook, Volume I
    ' by Getz, Litwin, and Gilbert. (Sybex)
    ' Copyright 1999. All rights reserved.
    '
    ' Displays the CommonDialog control's Save As dialog box.
    
    Dim ofn As OPENFILENAME
    Dim lngErr As Long
    
    Call SetOpenProperties(ofn)
    If GetSaveFileName(ofn) <> 0 Then
        Call GetOpenProperties(ofn)
    Else
        lngErr = CommDlgExtendedError()
        Select Case lngErr
            Case FNERR_BUFFERTOOSMALL
                Err.Raise cdlBufferTooSmall, , "Filename buffer is too small for the selected files."
            Case 0
                ' If the user wants to raise an error for the Escape
                ' do it now.
                If CancelError Then
                    Err.Raise cdlCancel, , "Cancel was selected."
                End If
            Case Else
                Err.Raise lngErr, , "Unexpected error."
        End Select
    End If
End Sub
 
Private Sub SetOpenProperties(ofn As OPENFILENAME)
    
    ' From Access 2000 Developer's Handbook, Volume I
    ' by Getz, Litwin, and Gilbert. (Sybex)
    ' Copyright 1999. All rights reserved.
    '
    
    ' Copy object properties into the data
    ' structure before calling the API.
    
    Dim strFileName As String
    Dim strFileTitle As String
  
    ' Show the Open common dialog.
    ' Allocate string space for the returned strings.
    strFileName = String(FileNameBufferSize, vbNullChar)
    LSet strFileName = FileName & vbNullChar
    strFileTitle = String$(1024, vbNullChar)
    
    With ofn
        .lStructSize = Len(ofn)
        .hWndOwner = hWndOwner
        ' The API doesn't want those "|" things, it wants
        ' vbNullChar, with an extra one on the end.
        .lpstrFilter = Replace(Trim$(Filter), "|", vbNullChar) & vbNullChar
        .nFilterIndex = FilterIndex
        .lpstrFile = strFileName
        
        .nMaxFile = Len(strFileName)
        .lpstrFileTitle = strFileTitle
        .nMaxFileTitle = Len(strFileTitle)
        .lpstrTitle = DialogTitle
        
        ' You can set either the OpenFlags
        ' or general Flags properties. We'll
        ' OR them together. If you use both, you'd
        ' better know what you're doing!
        ' In addition, we're going to assume that you
        ' always want the explorer-style interface.
        ' Can't imagine why you wouldn't, at this point.
        .Flags = OpenFlags Or Flags Or cdlOFNExplorer
        .lpstrDefExt = DefaultExt
        .lpstrInitialDir = InitDir
 
        ' We don't support the CustomFilter
        ' property, but you could add it in
        ' if you like. This buffer
        ' must contain at least 40 characters
        ' to make WinNT happy.
        .lpstrCustomFilter = String(40, vbNullChar)
        .nMaxCustFilter = Len(.lpstrCustomFilter)
        
        If .Flags And cdlOFNEnableHook Then
            .lpfnHook = CallBack
        End If
    End With
End Sub
 
Private Sub GetOpenProperties(ofn As OPENFILENAME)
    
    ' From Access 2000 Developer's Handbook, Volume I
    ' by Getz, Litwin, and Gilbert. (Sybex)
    ' Copyright 1999. All rights reserved.
    '
        
    ' Retrieve properties from the API structure
    ' back into properties of this object.
    
    Dim astrFileInfo() As String
    Dim intPos As Integer
    Dim strFileName As String
    
    With ofn
        FileName = .lpstrFile
        OpenFlags = .Flags
        Flags = .Flags
        FileTitle = .lpstrFileTitle
        FilterIndex = .nFilterIndex
        mlngFileExtOffset = .nFileExtension
        mlngFileOffset = .nFileOffset
        ' CustomFilter = .lpstrCustomFilter
        If .nFileOffset > 0 Then
            strFileName = .lpstrFile
            If Mid$(strFileName, mlngFileOffset, 1) = vbNullChar Then
                ' Look for trailing double null chars, and trim
                ' the string there.
                intPos = InStr(1, strFileName, vbNullChar & vbNullChar)
                If intPos > 0 Then
                    strFileName = Left$(strFileName, intPos - 1)
                End If
                astrFileInfo = Split(strFileName, vbNullChar)
                mastrFileList = astrFileInfo
            Else
                ' Only a single file selected,
                ' so break it up into path and file
                ' portion, as if the user had selected
                ' multiple files.
                ReDim mastrFileList(0 To 1)
                mastrFileList(0) = Left$(strFileName, mlngFileOffset - 1)
                mastrFileList(1) = adhTrimNull(Mid$(strFileName, mlngFileOffset + 1))
                FileName = adhTrimNull(FileName)
            End If
        End If
    End With
End Sub
 
Private Sub SetColorProperties(cc As ChooseColor)
    
    ' From Access 2000 Developer's Handbook, Volume I
    ' by Getz, Litwin, and Gilbert. (Sybex)
    ' Copyright 1999. All rights reserved.
    '
    
    ' Copy object properties into the data
    ' structure before calling the API.
    
    cc.lStructSize = LenB(cc)
    cc.hWndOwner = hWndOwner
    cc.rgbResult = Color
    cc.lpCustColors = VarPtr(malngColors(0))
    
    ' You can set either the ColorFlags
    ' or general Flags properties. We'll
    ' OR them together. If you use both, you'd
    ' better know what you're doing!
    cc.Flags = ColorFlags Or Flags
    
    ' This had better be the address of
    ' a public function in a standard
    ' module, or you're going down!
    ' Use the adhFnPtrToLong procedure
    ' to convert from AddressOf to
    ' long.
    If cc.Flags And cdlCCEnableHook Then
        cc.lpfnHook = CallBack
    End If
End Sub
 
Private Sub GetColorProperties(cc As ChooseColor)
    ' From Access 2000 Developer's Handbook, Volume I
    ' by Getz, Litwin, and Gilbert. (Sybex)
    ' Copyright 1999. All rights reserved.
    '
        
    ' Retrieve properties from the API structure
    ' back into properties of this object.
    
    Color = cc.rgbResult
End Sub
 
Private Sub SetFontProperties( _
 cf As ChooseFont, lf As LOGFONT, strStyle As String)
    ' From Access 2000 Developer's Handbook, Volume I
    ' by Getz, Litwin, and Gilbert. (Sybex)
    ' Copyright 1999. All rights reserved.
    '
    
    ' Copy object properties into the data
    ' structure before calling the API.
    
    On Error Resume Next
    Dim lngFlags As Long
    
    cf.lStructSize = LenB(cf)
    If Len(FontName) > 0 Then
        Call adhSetFaceName(lf, FontName)
    End If
    cf.lpLogFont = VarPtr(lf)
    cf.hWndOwner = hWndOwner
    cf.lpszStyle = FontStyle
        
    lf.lfHeight = CalcHeightFromPoints()
    lf.lfStrikeOut = FontStrikeThrough
    lf.lfUnderline = FontUnderline
    lf.lfItalic = FontItalic
    lf.lfCharSet = FontScript
    
    If FontWeight = 0 Then
        If FontBold Then
            lf.lfWeight = 700
        Else
            lf.lfWeight = 400
        End If
    Else
        lf.lfWeight = FontWeight
    End If
    
    cf.rgbColors = FontColor
    cf.nSizeMax = Max
    cf.nSizeMin = Min
    
    ' You can set either the FontFlags
    ' or general Flags properties. We'll
    ' OR them together. If you use both, you'd
    ' better know what you're doing!
    ' We also OR in cdlCFInitToLogFontStruct,
    ' 'cause you generally want to do that.
    
    ' In addition, if the user hasn't specified
    ' either/both cdlCFPrinterFonts or cdlCFScreenFonts
    ' we're going to assume they want both.
    lngFlags = Flags Or FontFlags
    If Not (lngFlags And cdlCFPrinterFonts) And _
     Not (lngFlags And cdlCFScreenFonts) Then
        lngFlags = lngFlags Or cdlCFBoth
    End If
    cf.Flags = lngFlags Or cdlCFInitToLogFontStruct
    
    ' This had better be the address of
    ' a public function in a standard
    ' module, or you're going down!
    ' Use the adhFnPtrToLong procedure
    ' to convert from AddressOf to
    ' long.
    If cf.Flags And cdlCFEnableHook Then
        cf.lpfnHook = CallBack
    End If
End Sub
 
Private Sub GetFontProperties(cf As ChooseFont, lf As LOGFONT)
    
    ' From Access 2000 Developer's Handbook, Volume I
    ' by Getz, Litwin, and Gilbert. (Sybex)
    ' Copyright 1999. All rights reserved.
    '
    ' Retrieve properties from the API structure
    ' back into properties of this object.
    
    On Error Resume Next
    FontName = adhTrimNull(StrConv(lf.lfFaceName, vbUnicode))
    FontColor = cf.rgbColors
    FontItalic = lf.lfItalic
    FontBold = ((cf.nFontType And BOLD_FONTTYPE) <> 0)
    FontWeight = lf.lfWeight
    FontSize = cf.iPointSize \ 10
    FontStrikeThrough = lf.lfStrikeOut
    FontUnderline = lf.lfUnderline
    FontScript = lf.lfCharSet
    FontStyle = adhTrimNull(cf.lpszStyle)
    mlngFontType = cf.nFontType
End Sub
 
Private Function CalcHeightFromPoints() As Long
    
    ' From Access 2000 Developer's Handbook, Volume I
    ' by Getz, Litwin, and Gilbert. (Sybex)
    ' Copyright 1999. All rights reserved.
    '
    Dim hdc As Long
    Dim lngLogPixelsY As Long
    
    On Error GoTo HandleErrors
    
    ' Assume an invalid value for failure.
    CalcHeightFromPoints = 0
    
    ' Convert from points back to the internal
    ' device units value.
    hdc = GetDC(HWND_DESKTOP)
    If hdc <> 0 Then
        lngLogPixelsY = GetDeviceCaps(hdc, LOGPIXELSY)
        CalcHeightFromPoints = _
         -1 * MulDiv(CInt(FontSize), lngLogPixelsY, 72)
    End If
 
ExitHere:
    Exit Function
 
HandleErrors:
    Resume ExitHere
End Function
 
Private Sub Class_Initialize()
    ' Assume the default size.
   ' FileNameBufferSize = 20000
   FileNameBufferSize = 50000
End Sub
 
Private Function adhTrimNull(strVal As String) As String
    ' From Access 2000 Developer's Handbook, Volume I
    ' by Getz, Litwin, and Gilbert. (Sybex)
    ' Copyright 1999. All rights reserved.
    
    ' Trim the end of a string, stopping at the first
    ' null character.
    
    Dim intPos As Integer
    intPos = InStr(1, strVal, vbNullChar)
    Select Case intPos
        Case Is > 1
            adhTrimNull = Left$(strVal, intPos - 1)
        Case 0
            adhTrimNull = strVal
        Case 1
            adhTrimNull = vbNullString
    End Select
End Function
 
Private Sub adhSetFaceName(lf As LOGFONT, strValue As String)
    
    ' From Access 2000 Developer's Handbook, Volume I
    ' by Getz, Litwin, and Gilbert. (Sybex)
    ' Copyright 1999. All rights reserved.
    '
    ' Given a string, get it back into the ANSI byte array
    ' contained within a LOGFONT structure.
    
    Dim intLen As Integer
    Dim intI As Integer
    Dim abytTemp() As Byte
    
    On Error GoTo HandleErrors
    
    abytTemp = StrConv(strValue, vbFromUnicode)
    intLen = UBound(abytTemp) + 1
    
    ' Make sure the string isn't too long.
    If intLen > LF_FACESIZE - 1 Then
        intLen = LF_FACESIZE - 1
    End If
    For intI = 1 To intLen
        lf.lfFaceName(intI) = abytTemp(intI - 1)
    Next intI
    ' Tack on a final Chr$(0).
    lf.lfFaceName(intI) = 0
    
ExitHere:
    Exit Sub
    
HandleErrors:
    Resume ExitHere
End Sub