Attribute VB_Name = "mFontDialog"
Option Explicit

' Constantes
Const FW_NORMAL = 400
Const CF_SCREENFONTS = &H1
Const CF_EFFECTS = &H100&
Const CF_FORCEFONTEXIST = &H10000
Const CF_INITTOLOGFONTSTRUCT = &H40&
Const GMEM_MOVEABLE = &H2
Const REGULAR_FONTTYPE = &H400
Const GMEM_ZEROINIT = &H40

' Tipos
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 As String * 31
End Type
Private Type CHOOSEFONT
    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 String
    hInstance As Long
    lpszStyle As String
    nFontType As Integer
    MISSING_ALIGNMENT As Integer
    nSizeMin As Long
    nSizeMax As Long
End Type
Public Type FontProperties
    stName As String
    blItalic As Boolean
    itSize As Integer
    itHeigth As Integer
    itWeight As Integer
    blUnderline As Boolean
    blStrikethru As Boolean
    btCharset As Byte
End Type

' APIs
Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) As Long


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Exibe tela de seleção de fontes, retorna conjunto de propriedades selecionadas
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function ShowFont(hWnd As Long, defaults As FontProperties) As FontProperties
    Dim cf As CHOOSEFONT, lfont As LOGFONT, hMem As Long, pMem As Long
    Dim fontname As String, retval As Long
    
    ' Valores padrões
    lfont.lfWeight = defaults.itWeight
    If (defaults.itHeigth <> 0) Then lfont.lfHeight = defaults.itHeigth Else lfont.lfHeight = defaults.itSize - 26
    If (defaults.blItalic) Then lfont.lfItalic = 255 Else lfont.lfItalic = 0
    If (defaults.blStrikethru) Then lfont.lfStrikeOut = 255 Else lfont.lfStrikeOut = 0
    If (defaults.blUnderline) Then lfont.lfUnderline = 255 Else lfont.lfUnderline = 0
    lfont.lfCharSet = defaults.btCharset
    If (Len(defaults.stName) < 31) Then lfont.lfFaceName = defaults.stName & vbNullChar Else lfont.lfFaceName = defaults.stName

    ' Aloca memória para poder copiá-la
    hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(lfont))
    pMem = GlobalLock(hMem)
    
    ' Copia variáveis
    CopyMemory ByVal pMem, lfont, Len(lfont)

    ' Parâmetros para o commondialog
    cf.lStructSize = Len(cf)
    cf.hwndOwner = hWnd
    cf.lpLogFont = pMem
    cf.iPointSize = fn_Size * 10
    cf.flags = CF_SCREENFONTS Or CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT
    cf.rgbColors = RGB(0, 0, 0)
    cf.nFontType = REGULAR_FONTTYPE
    
    ' Abre tela
    retval = CHOOSEFONT(cf)
    
    ' Se confirmou
    If (retval <> LN_NO_ERROR) Then
        
        ' Copia a volta
        CopyMemory lfont, ByVal pMem, Len(lfont)
        
        ' Fim do nome da fonte
        retval = InStr(lfont.lfFaceName, vbNullChar)
        
        ' Se encontrou fim
        If (retval > 0) Then
            
            ' Remove restante
            ShowFont.stName = Left(lfont.lfFaceName, retval - 1)
        Else
            
            ' Usa todo o nome
            ShowFont.stName = lfont.lfFaceName
        End If
        
        ' Outras propriedades
        ShowFont.btCharset = CByte(lfont.lfCharSet)
        ShowFont.itSize = CInt(cf.iPointSize / 10)
        ShowFont.itWeight = CInt(lfont.lfWeight)
        ShowFont.blItalic = (lfont.lfItalic > 0)
        ShowFont.blStrikethru = (lfont.lfStrikeOut > 0)
        ShowFont.blUnderline = (lfont.lfUnderline > 0)
        ShowFont.itHeigth = CInt(lfont.lfHeight)
    Else
        
        ' Seta sem seleção
        ShowFont.stName = ST_INVALID_VALUE
    End If

    ' Libera memória
    GlobalUnlock hMem
    GlobalFree hMem
End Function