Solved

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

Posted on 1998-07-29
4
220 Views
Last Modified: 2013-12-03
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
Comment
Question by:kotus
  • 2
4 Comments
 
LVL 6

Expert Comment

by:clifABB
ID: 1467173
 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
 

Author Comment

by:kotus
ID: 1467174
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
 
LVL 2

Accepted Solution

by:
shchuka earned 100 total points
ID: 1467175
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
 

Author Comment

by:kotus
ID: 1467176
Shchuka, excellent! Thanks!
0

Featured Post

Top 6 Sources for Identifying Threat Actor TTPs

Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

Join & Write a Comment

Introduction While answering a recent question (http://www.experts-exchange.com/Q_27402310.html) in the VB classic zone, I wrote some VB code in the (Office) VBA environment, rather than fire up my older PC.  I didn't post completely correct code o…
You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…

747 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now