“字体”对话框的疑惑

Question

接上面
Public Function FontDlg(OwnerhWnd As Long, objName As Object, Optional lFlags As FontFlagsConstants = -1, Optional sInitName As String = "宋体", Optional lInitSize As Long = 9, Optional lInitStyle As FontStyleConstants = flgRegular, Optional lInitColor As Long = 0, Optional bInitUnderLine As Boolean = False, Optional bInitStrikeLine As Boolean = False) As Boolean
    Dim cf As CHOOSEFONT, lfont As LOGFONT, hMem As Long, pMem As Long
    Dim fontname As String, retval As Long
    Dim lngFlags As Long
    If lFlags = -1 Then
        lngFlags = flgBoth Or flgEffects Or flgForceFontExist Or flgLimitSize Or CF_INITTOLOGFONTSTRUCT
    Else
        lngFlags = lFlags Or CF_INITTOLOGFONTSTRUCT
    End If
    lfont.lfHeight = 0  ' 默认高度
    lfont.lfWidth = 0  ' 默认宽度
    lfont.lfEscapement = 0  ' angle between baseline and escapement vector
    lfont.lfOrientation = 0  ' angle between baseline and orientation vector
    ' normal weight i.e. not bold
    lfont.lfWeight = FW_All
    lfont.lfCharSet = CHARSET_ALL ' use default character set
    lfont.lfOutPrecision = OUT_DEFAULT_PRECIS  ' default precision mapping
    lfont.lfClipPrecision = CLIP_DEFAULT_PRECIS  ' default clipping precision
    lfont.lfQuality = QUALITY_ALL ' default quality setting
    lfont.lfPitchAndFamily = PITCH_ALL Or FF_ALL  ' default pitch, proportional with serifs
    lfont.lfFaceName = sInitName & vbNullChar  ' string must be null-terminated
    lfont.lfUnderline = bInitUnderLine
    lfont.lfStrikeOut = bInitStrikeLine
    ' Create the memory block which will act as the LOGFONT structure buffer.
    hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(lfont))
    pMem = GlobalLock(hMem)  ' lock and get pointer
    CopyMemory ByVal pMem, lfont, Len(lfont)  ' copy structure's contents into block
    ' Initialize dialog box: Screen and printer fonts, point size between 10 and 72.
    cf.lStructSize = Len(cf)  ' size of structure
    cf.hwndOwner = OwnerhWnd  ' window Form1 is opening this dialog box
    cf.hdc = Printer.hdc  ' device context of default printer (using VB's mechanism)
    cf.lpLogFont = pMem   ' pointer to LOGFONT memory block buffer
    cf.iPointSize = lInitSize * 10  ' 12 point font (in units of 1/10 point)
    cf.flags = lngFlags 'CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE
    cf.rgbColors = lInitColor  ' color
    cf.nFontType = lInitStyle  ' regular font type i.e. not bold or anything
    cf.nSizeMin = 2  ' minimum point size
    cf.nSizeMax = 72  ' maximum point size
    ' Now, call the function.  If successful, copy the LOGFONT structure back into the structure
    ' and then print out the attributes we mentioned earlier that the user selected.
    retval = CHOOSEFONT(cf)  ' open the dialog box
    If retval <> 0 Then  ' success
        CopyMemory lfont, ByVal pMem, Len(lfont)  ' copy memory back
        ' Now make the fixed-length string holding the font name into a "normal" string.
        objName.Font.Name = Left(lfont.lfFaceName, InStr(lfont.lfFaceName, vbNullChar) - 1)
        objName.Font.Size = cf.iPointSize / 10
        objName.ForeColor = cf.rgbColors
        objName.Font.Italic = lfont.lfItalic
        objName.Font.Strikethrough = lfont.lfStrikeOut
        objName.Font.UnderLine = lfont.lfUnderline
        Debug.Print  ' end the line
    End If
    ' Deallocate the memory block we created earlier.  Note that this must
    ' be done whether the function succeeded or not.
    retval = GlobalUnlock(hMem)  ' destroy pointer, unlock block
    retval = GlobalFree(hMem)  ' free the allocated memory
End Function

Answer 1

Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Function FontDlg(OwnerhWnd As Long, objName As Object, Optional lFlags As FontFlagsConstants = -1, Optional sInitName As String = "宋体", Optional lInitSize As Long = 9, Optional lInitStyle As FontStyleConstants = flgRegular, Optional lInitColor As Long = 0, Optional bInitUnderLine As Boolean = False, Optional bInitStrikeLine As Boolean = False) As Boolean
    Dim cf As CHOOSEFONT, lfont As LOGFONT, hMem As Long, pMem As Long
    Dim fontname As String, retval As Long
    Dim lngFlags As Long
    If lFlags = -1 Then
        lngFlags = flgBoth Or flgEffects Or flgForceFontExist Or flgLimitSize Or CF_INITTOLOGFONTSTRUCT
    Else
        lngFlags = lFlags Or CF_INITTOLOGFONTSTRUCT
    End If
    lfont.lfHeight = 0  ' 默认高度
    lfont.lfWidth = 0  ' 默认宽度
    lfont.lfEscapement = 0  ' angle between baseline and escapement vector
    lfont.lfOrientation = 0  ' angle between baseline and orientation vector
    ' normal weight i.e. not bold
    lfont.lfWeight = FW_All
    lfont.lfCharSet = CHARSET_ALL ' use default character set
    lfont.lfOutPrecision = OUT_DEFAULT_PRECIS  ' default precision mapping
    lfont.lfClipPrecision = CLIP_DEFAULT_PRECIS  ' default clipping precision
    lfont.lfQuality = QUALITY_ALL ' default quality setting
    lfont.lfPitchAndFamily = PITCH_ALL Or FF_ALL  ' default pitch, proportional with serifs
    lfont.lfFaceName = sInitName & vbNullChar  ' string must be null-terminated
    lfont.lfUnderline = bInitUnderLine
    lfont.lfStrikeOut = bInitStrikeLine
    ' Create the memory block which will act as the LOGFONT structure buffer.
    hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(lfont))
    pMem = GlobalLock(hMem)  ' lock and get pointer
    CopyMemory ByVal pMem, lfont, Len(lfont)  ' copy structure's contents into block
    ' Initialize dialog box: Screen and printer fonts, point size between 10 and 72.
    cf.lStructSize = Len(cf)  ' size of structure
    cf.hwndOwner = OwnerhWnd  ' window Form1 is opening this dialog box
    cf.hdc = Printer.hdc  ' device context of default printer (using VB's mechanism)
    cf.lpLogFont = pMem   ' pointer to LOGFONT memory block buffer
    cf.iPointSize = lInitSize * 10  ' 12 point font (in units of 1/10 point)
    cf.flags = lngFlags 'CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE
    cf.rgbColors = lInitColor  ' color
    cf.nFontType = lInitStyle  ' regular font type i.e. not bold or anything
    cf.nSizeMin = 2  ' minimum point size
    cf.nSizeMax = 72  ' maximum point size
    ' Now, call the function.  If successful, copy the LOGFONT structure back into the structure
    ' and then print out the attributes we mentioned earlier that the user selected.
    retval = CHOOSEFONT(cf)  ' open the dialog box
    If retval <> 0 Then  ' success
        CopyMemory lfont, ByVal pMem, Len(lfont)  ' copy memory back
        ' Now make the fixed-length string holding the font name into a "normal" string.
        objName.Font.Name = Left(lfont.lfFaceName, InStr(lfont.lfFaceName, vbNullChar) - 1)
        objName.Font.Size = cf.iPointSize / 10
        objName.ForeColor = cf.rgbColors
        objName.Font.Italic = lfont.lfItalic
        objName.Font.Strikethrough = lfont.lfStrikeOut
        objName.Font.UnderLine = lfont.lfUnderline
        Debug.Print  ' end the line
    End If
    ' Deallocate the memory block we created earlier.  Note that this must
    ' be done whether the function succeeded or not.
    retval = GlobalUnlock(hMem)  ' destroy pointer, unlock block
    retval = GlobalFree(hMem)  ' free the allocated memory
End Function

Answer 2

Private Type LOGFONT
        lfHeight As Long '字号
        lfWidth As Long '字体宽度（对于字体对话框无效）
        lfEscapement As Long '旋转角度
        lfOrientation As Long '单个字符的旋转角度（好像没有用）
        lfWeight As Long '字符粗细（400正常，700粗体）
        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