0

我正在使用 VB6 的通用对话框控件通过调用 ShowFont 方法来选择字体。在这里，我可以选择所需的字体、字体大小、粗体、斜体、直通等。我还从脚本组合框中选择阿拉伯语。问题无法获得我从脚本组合框中选择的值。任何人请帮助。

代码：

With CommonDialog1.ShowFont 
    FontObject.Name = .FontName 
    FontObject.Bold = .FontBold 
    FontObject.Italic = .FontItalic 
    FontObject.Size = .FontSize 
    FontObject.Strikethrough = .FontStrikethru 
    FontObject.Underline = .FontUnderline 
End With
4

1 回答 1

1

你有两个选择：

  • 子类化通用对话框窗口 - 这是来自 VBForum 的示例
  • 使用 Windows API 自行调用 ChooseFont Common Dialog

这是使用第二种方法的片段：

Option Explicit

Private FontObject As New StdFont

Const FW_REGULAR As Integer = 400
Const FW_BOLD As Integer = 700
Const CF_BOTH = &H3
Const CF_EFFECTS = &H100
Const CF_INITTOLOGFONTSTRUCT = &H40
Const LF_FACESIZE = 32
Const LOGPIXELSY As Long = 90

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(LF_FACESIZE) As Byte
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

Private Declare Function GetDesktopWindow Lib "USER32" () As Long
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 Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function ChooseFontA Lib "comdlg32.dll" (pChoosefont As CHOOSEFONT) As Long

Private Sub String2ByteArr(ByVal str As String, ByRef arr)
    Dim b() As Byte, i As Long, l As Long
    b = StrConv(str & Chr(0), vbFromUnicode)
    l = UBound(b)
    For i = 0 To l
        arr(i) = b(i)
    Next
End Sub

Private Function ByteArr2String(ByRef arr) As String
    Dim b() As Byte
    b = StrConv(arr, vbUnicode)
    bytearray2string = Left$(b, InStr(b, Chr$(0)) - 1)
End Function

Private Sub FontDialog()
    Dim cf As CHOOSEFONT, lf As LOGFONT, hWnd As Long, hDC As Long, ppi As Long
    hWnd = GetDesktopWindow
    hDC = GetDC(hWnd)
    ppi = GetDeviceCaps(hDC, LOGPIXELSY)
    With lf
        String2ByteArr FontObject.Name, lf.lfFaceName
        .lfHeight = -(FontObject.Size * ppi) / 72
        .lfWeight = IIf(FontObject.Bold, FW_BOLD, FW_REGULAR)
        .lfItalic = FontObject.Italic
        .lfUnderline = FontObject.Underline
        .lfStrikeOut = FontObject.Strikethrough
        .lfCharSet = FontObject.Charset
    End With
    With cf
        .lStructSize = Len(cf)
        .hDC = hDC
        .flags = CF_BOTH Or CF_EFFECTS Or CF_INITTOLOGFONTSTRUCT
        .hwndOwner = Me.hWnd
        .lpLogFont = VarPtr(lf)
        .lpTemplateName = vbNullString
    End With
    If ChooseFontA(cf) Then
        With FontObject
            .Name = ByteArr2String(lf.lfFaceName)
            .Size = (-72 * lf.lfHeight) / ppi
            .Bold = lf.lfWeight >= FW_BOLD
            .Italic = lf.lfItalic
            .Underline = lf.lfUnderline
            .Strikethrough = lf.lfStrikeOut
            .Charset = lf.lfCharSet
        End With
        ' If you choose Arabic charset, this will print 178
        Debug.Print "CharSet:", FontObject.Charset 
    End If
    Call ReleaseDC(hWnd, hDC)
End Sub

请注意：由于这个话题已经很老了，您可以通过在网上搜索找到许多其他示例（ChooseFont: Using the ChooseFont Common Dialog API，Karl E. Peterson等）。

于 2017-05-15T10:21:28.573 回答