Custom Font Dialog

Imports System.Runtime.InteropServices

Public Class Form1

    ' --- Constants ---
    Public Const CF_SCREENFONTS As Integer = &H1
    Public Const CF_INITTOLOGFONTSTRUCT As Integer = &H40
    Public Const CF_EFFECTS As Integer = &H100
    Public Const CF_APPLY As Integer = &H200
    Public Const CF_ENABLEHOOK As Integer = &H8
    Public Const WM_INITDIALOG As UInteger = &H110

    ' --- Structures ---
    
    Public Structure LOGFONT
        Public lfHeight As Integer
        Public lfWidth As Integer
        Public lfEscapement As Integer
        Public lfOrientation As Integer
        Public lfWeight As Integer
        Public lfItalic As Byte
        Public lfUnderline As Byte
        Public lfStrikeOut As Byte
        Public lfCharSet As Byte
        Public lfOutPrecision As Byte
        Public lfClipPrecision As Byte
        Public lfQuality As Byte
        Public lfPitchAndFamily As Byte
        
        Public lfFaceName As String
    End Structure

    
    Public Structure CHOOSEFONT2
        Public lStructSize As Integer
        Public hwndOwner As IntPtr
        Public hDC As IntPtr
        Public lpLogFont As IntPtr
        Public iPointSize As Integer
        Public Flags As Integer
        Public rgbColors As Integer
        Public lCustData As IntPtr
        Public lpfnHook As FormatCharDlgProc
        Public lpTemplateName As String
        Public hInstance As IntPtr
        Public lpszStyle As String
        Public nFontType As Short
        Public ___MISSING_ALIGNMENT__ As Short
        Public nSizeMin As Integer
        Public nSizeMax As Integer
    End Structure

    ' --- Delegates ---
    Public Delegate Function FormatCharDlgProc(hdlg As IntPtr, msg As UInteger, wParam As IntPtr, lParam As IntPtr) As Integer

    ' --- WinAPI Functions ---
    
    Public Shared Function ChooseFont(ByRef cf As CHOOSEFONT2) As Boolean
    End Function

    
    Public Shared Function SetWindowText(hWnd As IntPtr, lpString As String) As Boolean
    End Function

    ' --- Hook Procedure ---
    Public Function MyFontHookProc(hdlg As IntPtr, msg As UInteger, wParam As IntPtr, lParam As IntPtr) As Integer
        If msg = WM_INITDIALOG Then
            SetWindowText(hdlg, "Custom Font Picker")
        End If
        Return 0
    End Function

    ' --- Show Font Dialog Button Handler ---
    Private Sub btnShowFontDialog_Click(sender As Object, e As EventArgs) Handles btnShowFontDialog.Click
        Dim logFont As New LOGFONT()
        logFont.lfFaceName = New String(Chr(0), 32)

        Dim pLogFont As IntPtr = Marshal.AllocHGlobal(Marshal.SizeOf(logFont))
        Marshal.StructureToPtr(logFont, pLogFont, False)

        Dim cf As New CHOOSEFONT2()
        cf.lStructSize = Marshal.SizeOf(cf)
        cf.hwndOwner = Me.Handle
        cf.lpLogFont = pLogFont
        cf.Flags = CF_SCREENFONTS Or CF_INITTOLOGFONTSTRUCT Or CF_EFFECTS Or CF_ENABLEHOOK
        cf.lpfnHook = New FormatCharDlgProc(AddressOf MyFontHookProc)

        If ChooseFont(cf) Then
            Dim selectedFont As LOGFONT = Marshal.PtrToStructure(Of LOGFONT)(cf.lpLogFont)
            MessageBox.Show("Selected Font: " & selectedFont.lfFaceName.Trim())
        End If

        Marshal.FreeHGlobal(pLogFont)
    End Sub

End Class