Question

我使用VB6的Common Dialog Control通过调用ShowFont方法选择Font。在这里，我可以选择所需的字体，字体大小，粗体，斜体，打击等。我还从脚本组合框中选择阿拉伯语。问题是无法获取我从“脚本”组合框中选择的值。请任何人帮忙。

代码：

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

Answer 1

您有两种选择：

通用对话窗口的子类 - Here是VBForum
使用Windows API自行调用ChooseFont公共对话框

以下是使用第二种方法的代码段：

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等）找到许多其他示例。

从VB6中的Common Dialog控件的Script Combo框中获取选定的值

1 个答案: