--------------------------------------------------------------------------------

Code:

Public Delegate Function CFHookProcDelegate(ByVal hdlg As Integer, ByVal msg As Integer, ByVal wParam As Integer, ByVal lParam As Integer) As Integer

Public Function ShowDialog() As DialogResult
    PopulateCFStructure()

    ' Show the dialog
    If Not API.CHOOSEFONT(m_cf) Then
        Dim ret As Integer = API.CommDlgExtendedError()
            Select Case ret
                Case 0
                Case API.CommonDialogError.DialogFailure
                    Throw New ApplicationException(("Couldn't show Dialog - Dialog Failure (" + ret.ToString + ")"))
                Case API.CommonDialogError.FindResFailure
                    Throw New ApplicationException(("Couldn't show Dialog - Find Resource Failure (" + ret.ToString + ")"))
                Case API.CommonDialogError.GeneralCodes
                    Throw New ApplicationException(("Couldn't show Dialog - General Codes Failure (" + ret.ToString + ")"))
                Case API.CommonDialogError.Initialization
                    Throw New ApplicationException(("Couldn't show Dialog - Initialization Failure (" + ret.ToString + ")"))
                Case API.CommonDialogError.LoadResFailure
                    Throw New ApplicationException(("Couldn't show Dialog - Load Resource Failure (" + ret.ToString + ")"))
                Case API.CommonDialogError.LoadStrFailure
                    Throw New ApplicationException(("Couldn't show Dialog - Load String Failure (" + ret.ToString + ")"))
                Case API.CommonDialogError.LockResFailure
                    Throw New ApplicationException(("Couldn't show Dialog - Lock Resource Failure (" + ret.ToString + ")"))
                Case API.CommonDialogError.MemAllocFailure
                    Throw New ApplicationException(("Couldn't show Dialog - Memory Allocation Failure (" + ret.ToString + ")"))
                Case API.CommonDialogError.MemLockFailure
                    Throw New ApplicationException(("Couldn't show Dialog - Memory Lock Failure (" + ret.ToString + ")"))
                Case API.CommonDialogError.NoHInstance
                    Throw New ApplicationException(("Couldn't show Dialog - No HInstance Failure (" + ret.ToString + ")"))
                Case API.CommonDialogError.NoHook
                    Throw New ApplicationException(("Couldn't show Dialog - No Hook Failure (" + ret.ToString + ")"))
                Case API.CommonDialogError.RegisterMsgFail
                    Throw New ApplicationException(("Couldn't show Dialog - Register Message Failure (" + ret.ToString + ")"))
                Case API.CommonDialogError.NoTemplate
                    Throw New ApplicationException(("Couldn't show Dialog - No Template Failure (" + ret.ToString + ")"))
                Case API.CommonDialogError.StructSize
                    Throw New ApplicationException(("Couldn't show Dialog - Structure Size Failure (" + ret.ToString + ")"))
                Case Else
                    Throw New ApplicationException(("Couldn't show Dialog - (" + ret.ToString + ")"))
            End Select
            m_Color = Nothing
            Return DialogResult.Cancel
        Else
            Dim cancelCheck As New CancelEventArgs()

            RaiseEvent FileOK(Me, cancelCheck)
            If cancelCheck.Cancel Then
                m_Color = Nothing
                Return DialogResult.Cancel
            Else
                Dim iFontStyle As Integer
                Dim R As Integer = m_cf.rgbColors And &HFF
                Dim G As Integer = (m_cf.rgbColors >> 8) And &HFF
                Dim B As Integer = (m_cf.rgbColors >> 16) And &HFF
                Dim retLogFont As API.LOGFONT = CType(Marshal.PtrToStructure(New IntPtr(m_cf.lpLogFont), GetType(API.LOGFONT)), API.LOGFONT)

                Me.Color = Color.FromArgb(R, G, B)
                iFontStyle = FontStyle.Regular
                If m_cf.nFontType And API.FontType.Bold Then
                    iFontStyle = iFontStyle Or FontStyle.Bold
                End If
                If m_cf.nFontType And API.FontType.Italic Then
                    iFontStyle = iFontStyle Or FontStyle.Italic
                End If
                If retLogFont.lfStrikeOut Then
                    iFontStyle = iFontStyle Or FontStyle.Strikeout
                End If
                If retLogFont.lfUnderline Then
                    iFontStyle = iFontStyle Or FontStyle.Underline
                End If

                Me.Font = New Font(retLogFont.lfFaceName, -retLogFont.lfHeight, iFontStyle, GraphicsUnit.Pixel)

                Return DialogResult.OK
            End If
        End If
End Function

Private Function GetFlags() As Integer
    Dim Flags As Integer

    Flags = API.ChooseColorFlags.EnableHook Or API.ChooseFontFlags.InitToLogFontStruct Or API.ChooseFontFlags.Both Or API.ChooseFontFlags.Effects
    If m_ShowHelp Then Flags = Flags Or API.ChooseColorFlags.ShowHelp

    Return Flags
End Function

Private Function PopulateCFStructure() As Boolean
    Try
        ' lfHeight is in Pixels. Convert Font.SizeInPoints to Pixels
        m_LogFont.lfHeight = -PointToPixels(m_Font.SizeInPoints)
        If m_Font.Bold Then
            m_LogFont.lfWeight = API.FontWeight.FW_BOLD
        Else
            m_LogFont.lfWeight = API.FontWeight.FW_NORMAL
        End If
        If m_Font.Italic Then
            m_LogFont.lfItalic = 1
        Else
            m_LogFont.lfItalic = 0
        End If
        If m_Font.Underline Then
            m_LogFont.lfUnderline = 1
        Else
            m_LogFont.lfUnderline = 0
        End If
        If m_Font.Strikeout Then
            m_LogFont.lfStrikeOut = 1
        Else
            m_LogFont.lfStrikeOut = 0
        End If
        m_LogFont.lfFaceName = m_Font.Name
        m_LogFont.lfCharSet = API.FontCharSet.DEFAULT_CHARSET
        m_LogFont.lfOutPrecision = API.FontPrecision.OUT_DEFAULT_PRECIS
        m_LogFont.lfClipPrecision = API.FontClipPrecision.CLIP_DEFAULT_PRECIS
        m_LogFont.lfQuality = API.FontQuality.DEFAULT_QUALITY
        m_LogFont.lfPitchAndFamily = API.FontPitchAndFamily.DEFAULT_PITCH Or API.FontPitchAndFamily.FF_ROMAN

        ptrLogFont = Marshal.AllocHGlobal(Marshal.SizeOf(m_LogFont))
        Marshal.StructureToPtr(m_LogFont, ptrLogFont, False)

        m_cf.lStructSize = Marshal.SizeOf(m_cf)
        m_cf.hwndOwner = m_hWnd
        m_cf.lpLogFont = ptrLogFont
        m_cf.iPointSize = m_Font.SizeInPoints * 10
        m_cf.flags = GetFlags()
        m_cf.lpfnHook = New API.CFHookProcDelegate(AddressOf HookProc)
        m_cf.rgbColors = m_Color.B
        m_cf.rgbColors = m_cf.rgbColors << 8
        m_cf.rgbColors = m_cf.rgbColors Or m_Color.G
        m_cf.rgbColors = m_cf.rgbColors << 8
        m_cf.rgbColors = m_cf.rgbColors Or m_Color.R
        m_cf.nSizeMax = 0
        m_cf.nSizeMin = 0

    Catch ex As Exception
        MsgBox("Error Creating CF Strucure: " & ex.Message)
        Return False
    End Try
End Function