从VB6中常用对话框控件的脚本组合框中获取选定值

我正在使用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

您有两个选择：

• 子类化公共对话框窗口- 是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

---

请注意：由于此主题非常古老，您可以通过在网上搜索（，等等）找到许多其他示例。

显示您的代码，请。@GiorgioBrausi-使用CommonDialog1.ShowFont FontObject.Name=.FontName FontObject.Bold=.FontBold FontObject.Italic=.FontItalic FontObject.Size=.FontSize FontObject.Streethrough=.FontStreethru FontObject.Underline=.FontUnderline End with脚本组合框似乎不起作用，可能是MS忘记修复的错误@Sachin您应该编辑问题并将代码放在那里，而不是放在注释中。尽可能将其格式化，以便阅读。您是否声明了

FontObject

？像

Dim FontObject这样的新StdFont

应该可以工作。