Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 251
  • Last Modified:

How do I retrieve (and use) font "script" ?

The Font Common Dialogue box allows you to choose a font "script" (eg. "Western"), but how can I detect which one was selected?

And assuming I have the Script, how can I use it? Ideally, I want to specify the Script when printing text in a Picturebox (using Picture1.Print or an API call).
0
kotus
Asked:
kotus
  • 2
1 Solution
 
clifABBCommented:
 CommonDialog1.Flags = cdlCFScreenFonts
  CommonDialog1.ShowFont
  Picture1.Font.Name = CommonDialog1.FontName
  Picture1.Font.Bold = CommonDialog1.FontBold
  Picture1.Font.Italic = CommonDialog1.FontItalic
  Picture1.Font.Size = CommonDialog1.FontSize
  Picture1.Font.Strikethrough = CommonDialog1.FontStrikethru
  Picture1.Font.Underline = CommonDialog1.FontUnderline

0
 
kotusAuthor Commented:
cliffABB, thanks... but this is exactly what I am doing already.
In addition to all the properties you listed, I need to know which font "script" was selected (eg. "Western").

As far as I can tell, there is no property returned by the Common Dialogue which gives this.

0
 
shchukaCommented:
I was faced with this problem a while ago - I had to do the font seletion through the API.  I'm sending you the code for a VB class which does that.  It's pretty easy.  Let me know, if you're having trouble understanding how it works.  Mainly, the method GetDlgFont opens a file dialog for the user to select the font.  After that, use the properties to retrieve the selected values.  In particular, the FontEncoding property is the one you are looking for.
Also, method ApplyFont will set the font of the given window to whatever you've selected.
(I have this file saved as FontMgr.cls).
'----------------
Option Explicit

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(32) As Byte
End Type

Private Type CHOOSEFONT
        lStructSize As Long
        hwndOwner As Long          '  caller's window handle
        hdc As Long                '  printer DC/IC or NULL
        lpLogFont As Long          '  ptr. to a LOGFONT struct
        iPointSize As Long         '  10 * size in points of selected font
        flags As Long              '  enum. type flags
        rgbColors As Long          '  returned text color
        lCustData As Long          '  data passed to hook fn.
        lpfnHook As Long           '  ptr. to hook function
        lpTemplateName As String   '  custom template name
        hInstance As Long          '  instance handle of.EXE that contains cust. dlg. template
        lpszStyle As String        '  return the style field here must be LF_FACESIZE or bigger
        nFontType As Integer       '  same value reported to the EnumFonts call back with the extra FONTTYPE_ bits added
        MISSING_ALIGNMENT As Integer
        nSizeMin As Long           '  minimum pt size allowed &
        nSizeMax As Long           '  max pt size allowed if CF_LIMITSIZE is used
End Type

Private lpChooseFont As CHOOSEFONT
Private lpLogFont As LOGFONT

Private Declare Function CommDlgExtendedError Lib "Comdlg32.dll" () As Long
Private Declare Function ChooseFontDlg Lib "Comdlg32.dll" Alias "ChooseFontA" (lpChooseFont As CHOOSEFONT) As Boolean
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Property Get mFontColor() As Long
    mFontColor = lpChooseFont.rgbColors
End Property
Public Property Let mFontColor(NewValue As Long)
    lpChooseFont.rgbColors = NewValue
End Property
Public Property Get mFontEncoding() As Byte
    mFontEncoding = lpLogFont.lfCharSet
End Property
Public Property Let mFontEncoding(NewValue As Byte)
    lpLogFont.lfCharSet = NewValue
End Property
Public Property Get mFontItalic() As Boolean
    mFontItalic = lpLogFont.lfItalic
End Property
Public Property Let mFontItalic(NewValue As Boolean)
    lpLogFont.lfItalic = NewValue
End Property
Public Property Get mFontName() As String
    Dim i As Integer
    Dim s As String
   
    s = ""
    With lpLogFont
        For i = 0 To 31
            If .lfFaceName(i) = 0 Then
                Exit For
            Else
                s = s & Chr$(.lfFaceName(i))
            End If
        Next i
    End With
    mFontName = s
End Property
Public Property Let mFontName(NewValue As String)
    Dim i As Integer
   
    With lpLogFont
        For i = 0 To 32: .lfFaceName(i) = 0: Next i
        For i = 0 To Len(NewValue) - 1
            If i > 31 Then
                Exit For
            Else
                .lfFaceName(i) = Asc(Mid$(NewValue, i + 1, 1))
            End If
        Next i
    End With
End Property
Public Property Get mFontSize() As Long
    mFontSize = lpChooseFont.iPointSize / 10
End Property
Public Property Let mFontSize(NewValue As Long)
    lpChooseFont.iPointSize = NewValue * 10
    lpLogFont.lfHeight = NewValue * 4 / 3
End Property
Public Property Get mFontStrikethru() As Boolean
    mFontStrikethru = lpLogFont.lfStrikeOut
End Property
Public Property Let mFontStrikethru(NewValue As Boolean)
    lpLogFont.lfStrikeOut = NewValue
End Property
Public Property Get mFontUnderline() As Boolean
    mFontUnderline = lpLogFont.lfUnderline
End Property
Public Property Let mFontUnderline(NewValue As Boolean)
    lpLogFont.lfUnderline = NewValue
End Property
Public Property Get mFontWeight() As Long
    mFontWeight = lpLogFont.lfWeight
End Property
Public Property Let mFontWeight(NewValue As Long)
    lpLogFont.lfWeight = NewValue
End Property
Public Sub ResetDefault()
    mFontName = "MS Sans Serif"
    With lpLogFont
        .lfHeight = 16          'default is 12 points, fontheight is 16
        .lfWidth = 0
        .lfEscapement = 0
        .lfOrientation = 0
        .lfWeight = 400         'Normal
        .lfItalic = False
        .lfUnderline = False
        .lfStrikeOut = False
        .lfCharSet = 0          'default charset is ANSI
        .lfOutPrecision = 5     'out_device_presic
        .lfClipPrecision = 0    'clip_default_presic
        .lfQuality = 0          'default quality
        .lfPitchAndFamily = 0   'default_pitch OR ff_dontcare
    End With
    With lpChooseFont
        .lStructSize = LenB(lpChooseFont)
        .hwndOwner = 0
        .hdc = 0
        .lpLogFont = VarPtr(lpLogFont)
        .iPointSize = 120           'default point size is 12
        .flags = &H12141            'cf_forcefontexist OR cf_limitsize OR cf_inittologfontstruct OR cf_screenfonts OR cf_effects
        .rgbColors = 0              'black
        .nFontType = &H400          'regular_fonttype
        .nSizeMin = 8
        .nSizeMax = 18
    End With
End Sub
Public Function GetDlgFont(Optional hOwner = 0) As Boolean
    Dim t As Long
    Dim r As Long
    Dim cf As CHOOSEFONT
    Dim lf As LOGFONT
   
    lf = lpLogFont
    cf = lpChooseFont
    cf.lpLogFont = VarPtr(lf)
    If hOwner = 0 Then hOwner = frmMDI.hwnd
    cf.hwndOwner = hOwner
    cf.hdc = GetDC(hOwner)
    t = ChooseFontDlg(cf)
    If t = 0 Then
        r = CommDlgExtendedError()
        If r <> 0 Then MsgBox "Common Dialog Error " & r, 16
        GetDlgFont = False
    Else
        lpLogFont = lf
        lpChooseFont = cf
        lpChooseFont.lpLogFont = VarPtr(lpLogFont)
        GetDlgFont = True
    End If
End Function
Public Function ApplyFont(Ctrl As Control) As Boolean
    Dim fnt As Long
    Dim r As Long
   
    fnt = CreateFontIndirect(lpLogFont)
    r = SendMessage(Ctrl.hwnd, &H30, fnt, True)
    Ctrl.ForeColor = mFontColor
End Function
Private Sub Class_Initialize()
    Call ResetDefault
End Sub
'-------------------------------
0
 
kotusAuthor Commented:
Shchuka, excellent! Thanks!
0

Featured Post

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now