Get selected value from Script Combo box of Common Dialog control in VB6

Question

I am using Common Dialog Control of VB6 to select Font by calling ShowFont method. Here I can select desired font, font size, bold, italic, strike thru etc. I also select Arabic from script combo box. The problem is not able to get the value which I selected from the Script combo box. Any one please help.

Code:

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

@GiorgioBrausi - with CommonDialog1 .ShowFont FontObject.Name = .FontName FontObject.Bold = .FontBold FontObject.Italic = .FontItalic FontObject.Size = .FontSize FontObject.Strikethrough = .FontStrikethru FontObject.Underline = .FontUnderline End with — Sachin, May 12 '17 at 07:25
It appears that the Script combobox does nothing and might be a bug MS forgot to fix. https://www.experts-exchange.com/questions/21421718/Common-Dialog-for-Fonts-Disable-or-hide-SCRIPT-combo-box.html — Slugsie, May 12 '17 at 10:35
@Sachin you should edit the question and put the code there, not in a comment. Format it as best as possible so it can be read. — StayOnTarget, May 12 '17 at 12:04
Did you declare `FontObject`? Something like `Dim FontObject As New StdFont` should work. — Jim Hewitt, May 12 '17 at 16:30
You probably want the Font's `Charset` property. Values are listed at https://msdn.microsoft.com/en-us/library/cc194829.aspx — Bob77, May 13 '17 at 05:48
Since the CommonDialog control does not expose a property for Charset you'd need to call the `ChooseFont` API yourself to obtain this value. — Bob77, May 13 '17 at 05:54

deblocker · Answer 1 · 2017-05-20T19:28:54.267

You have two options:

Subclass the Common Dialog Window - Here is an example from VBForum
Use the Windows API to call the ChooseFont Common Dialog by your self

Here is a snippet using the second approach:

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

Please note: as this topic is quite old, you will find many other examples by googling on the net (ChooseFont: Using the ChooseFont Common Dialog API, Karl E. Peterson and so on).

Get selected value from Script Combo box of Common Dialog control in VB6

1 Answers1