dcsimg
Results 1 to 10 of 10

Thread: List of LCID by Font character set

  1. #1

    Thread Starter
    Member Dragokas's Avatar
    Join Date
    Aug 2015
    Location
    Ukraine
    Posts
    530

    List of LCID by Font character set

    Hi,

    where can I find list of LCID that correspond to each character set: msdn.microsoft.com/en-us/library/cc194829.aspx

    I would like to change font in my program according to user LCID.

    E.g. if GetUserDefaultLCID() or display language or language for non-unicode programs is set to &H40D& it must be Font.CharSet = HEBREW_CHARSET.

    Of course I can just replace controls by Unicode version. But, I'll do it later.
    Also, is it possible to check if concrete font support concrete charset?
    Also, how to check is font unicode aware?

    I'm using such function to retrieve a list of fonts:
    Code:
    Public Function FontExist(sFontName As String) As Boolean
        Dim i As Long
        For i = 0 To Screen.FontCount - 1
            If StrComp(sFontName, Screen.Fonts(i), 1) = 0 Then
                FontExist = True
                Exit For
            End If
        Next i
    End Function
    Thanks.

  2. #2
    Fanatic Member
    Join Date
    Feb 2017
    Posts
    969

    Re: List of LCID by Font character set

    Hello. Not sure if this list of LCID's can help.

  3. #3
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    4,496

    Re: List of LCID by Font character set

    Interesting question, Dragokas.

    Here's some code I adapted to VB6 from VBA from a Microsoft site. It just lists (in Immediate Window) all the characters of a font that are supported. Be careful ... for a reasonably well fleshed-out font, it'll overflow the Immediate Window.

    I just bent it around so it examines the font in a Form1 (with the code placed in that Form1). Just click the form to get the list.

    Code:
    
    Option Explicit
    
    Private Const TWIPSPERINCH = 1440
    Private Const HORZRES = 8
    Private Const VERTRES = 10
    Private Const LOGPIXELSX = 88
    Private Const LOGPIXELSY = 90
    
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    
    'used with fnWeight
    Private Const FW_DONTCARE = 0
    Private Const FW_THIN = 100
    Private Const FW_EXTRALIGHT = 200
    Private Const FW_LIGHT = 300
    Private Const FW_NORMAL = 400
    Private Const FW_MEDIUM = 500
    Private Const FW_SEMIBOLD = 600
    Private Const FW_BOLD = 700
    Private Const FW_EXTRABOLD = 800
    Private Const FW_HEAVY = 900
    Private Const FW_BLACK = FW_HEAVY
    Private Const FW_DEMIBOLD = FW_SEMIBOLD
    Private Const FW_REGULAR = FW_NORMAL
    Private Const FW_ULTRABOLD = FW_EXTRABOLD
    Private Const FW_ULTRALIGHT = FW_EXTRALIGHT
    
    'used with fdwCharSet
    Private Const ANSI_CHARSET = 0
    Private Const DEFAULT_CHARSET = 1
    Private Const SYMBOL_CHARSET = 2
    Private Const SHIFTJIS_CHARSET = 128
    Private Const HANGEUL_CHARSET = 129
    Private Const CHINESEBIG5_CHARSET = 136
    Private Const OEM_CHARSET = 255
    
    'used with fdwOutputPrecision
    Private Const OUT_CHARACTER_PRECIS = 2
    Private Const OUT_DEFAULT_PRECIS = 0
    Private Const OUT_DEVICE_PRECIS = 5
    
    'used with fdwClipPrecision
    Private Const CLIP_DEFAULT_PRECIS = 0
    Private Const CLIP_CHARACTER_PRECIS = 1
    Private Const CLIP_STROKE_PRECIS = 2
    
    'used with fdwQuality
    Private Const DEFAULT_QUALITY = 0
    Private Const DRAFT_QUALITY = 1
    Private Const PROOF_QUALITY = 2
    
    'used with fdwPitchAndFamily
    Private Const DEFAULT_PITCH = 0
    Private Const FIXED_PITCH = 1
    Private Const VARIABLE_PITCH = 2
    
    Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
    Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Boolean, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    
    Private Type WCRANGE
      wcLow As Integer   'Low Unicode code point in the range of supported Unicode code points.
      cGlyphs As Integer 'Number of supported Unicode code points in this range.
    End Type
    
    Private Type GLYPHSET
      cbThis As Long           'The size, in bytes, of this structure.
      flAccel As Long          'Flags describing the maximum size of the glyph indices.
      cGlyphsSupported As Long 'The total number of Unicode code points supported in the font.
      cRanges As Long          'The total number of Unicode ranges in ranges.
      aRANGE() As WCRANGE      'Array of Unicode ranges that are supported in the font.
    End Type
    
    Private Const GGI_MARK_NONEXISTING_GLYPHS As Long = &H1
    Private Const GDI_ERROR As Long = &HFFFFFFFF
    Private Const INVALIDGLYPHINDEX As Integer = &HFFFF
    
    Private Declare Function GetFontUnicodeRanges Lib "gdi32.dll" (ByVal hDC As Long, lpGS As Any) As Long
    Private Declare Function GetGlyphIndices Lib "gdi32.dll" Alias "GetGlyphIndicesA" (ByVal hDC As Long, ByVal lpStr As String, ByVal lpStrLen As Long, ByVal pGI As Long, ByVal Flags As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal nCount As Long)
    
    Sub Form_Click()
    
    
      Dim GS As GLYPHSET
      Dim i As Long
    
    
      'Get the font from Form
      GS = GetGLYPHSET(Me.Font)
      'Write the headings
      Debug.Print "Nr   Unicode    Char"
      'Create the output
      For i = &H20& To &HFFFF&
            If HuntGLYPHSET(i, GS) Then
                If i < 256 Then
                    Debug.Print i, "U+" & Right$("0000" & Hex(i), 4), ChrW$(i)
                Else
                    Debug.Print i, "U+" & Right$("0000" & Hex(i), 4), "unicode"
                End If
            End If
      Next
    End Sub
    
    Private Function GetGLYPHSET(ByVal F As Font) As GLYPHSET
      'http://msdn.microsoft.com/en-us/library/windows/desktop/dd144887%28v=vs.85%29.aspx
      Dim Data() As Byte, i As Long, j As Long
      Dim Result As Long, Count As Long
      Dim GS As GLYPHSET
      Dim hDC As Long
    
      'Some of the propertys might not exists in the Font object
      On Error Resume Next
      Dim fSize As Integer, fBold As Integer
      Dim FName As String
      Dim fItalic As Boolean, fUnderline As Boolean, fStrikethrough As Boolean
      Dim hFont As Long, hOldFont As Long
      fSize = -MulDiv(F.Size, GetDeviceCaps(hDC, LOGPIXELSY), 72)
      FName = F.Name
      fBold = IIf(F.Bold, FW_BOLD, FW_NORMAL)
      fItalic = F.Italic
      fUnderline = F.Underline
      fStrikethrough = F.Strikethrough
      On Error GoTo 0
    
      'Create a device context compatible to the screen
      hDC = CreateCompatibleDC(GetDC(0&))
      If hDC = 0 Then Exit Function
      'Create font object
      hFont = CreateFont(fSize, 0, 0, 0, fBold, fItalic, fUnderline, fStrikethrough, _
        DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, _
        DEFAULT_PITCH, FName)
      If hFont = 0 Then Exit Function
      'Load the font into the device context, storing the original font object
      hOldFont = SelectObject(hDC, hFont)
    
      'Get the size of the GLYPHSET structure required to store the information
      Result = GetFontUnicodeRanges(hDC, ByVal 0&)
      If Result = 0 Then Exit Function
      ReDim Data(0 To (Result - 1)) As Byte
      'Get the data and the number of bytes written
      Result = GetFontUnicodeRanges(hDC, Data(LBound(Data)))
      If Result = 0 Then Exit Function
    
      'Coyp the first 4 LONG into the GLYPHSET structure
      i = LBound(Data)
      Count = 4 * 4
      CopyMemory GS, Data(i), Count
      i = i + Count
      With GS
        'Did the font support unicode?
        If .cRanges > 0 Then
          'Create the array of ranges and copy the data into there
          ReDim .aRANGE(0 To (.cRanges - 1)) As WCRANGE
          j = LBound(.aRANGE)
          Count = .cRanges
          Do While Count > 0
            CopyMemory .aRANGE(j), Data(i), Len(.aRANGE(j))
            i = i + Len(.aRANGE(j))
            j = j + 1
            Count = Count - 1
          Loop
        End If
      End With
      'Destroy the created objects and return results
      DeleteObject hFont
      DeleteDC hDC
      GetGLYPHSET = GS
    End Function
    
    Private Function HuntGLYPHSET(ByVal CharCode As Long, ByRef GS As GLYPHSET) As Boolean
      'Hunt through the GLYPHSET, True if the Unicode character is supported
      Dim i As Long, Low As Long
      With GS
        CharCode = CharCode + 1
        For i = 0 To .cRanges - 1
          With .aRANGE(i)
            If .wcLow < 0 Then
              Low = .wcLow And &HFFFF&
            Else
              Low = .wcLow
            End If
            If CharCode > Low Then
              If CharCode <= Low + .cGlyphs Then
                HuntGLYPHSET = True
                Exit Function
              End If
            End If
          End With
        Next
      End With
    End Function
    
    
    

    Maybe that'll help. There also seem to be several other API calls to get information on fonts (https://docs.microsoft.com/en-us/win...text-functions). Although I'm not finding a great many of them developed for VB6.

    It'll be interesting to see how this thread progresses.

    Good Luck,
    Elroy
    Last edited by Elroy; Aug 12th, 2018 at 12:46 PM.
    Any software I post in these forums written by me is provided “AS IS” without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. Please understand that I’ve been programming since the mid-1970s and still have some of that code. My contemporary VB6 project is approaching 1,000 modules. In addition, I have a “VB6 random code folder” that is overflowing. I’ve been at this long enough to truly not know with absolute certainty from whence every single line of my code has come, with much of it coming from programmers under my employ who signed intellectual property transfers. I have not deliberately attempted to remove any licenses and/or attributions from any software. If someone finds that I have inadvertently done so, I sincerely apologize, and, upon notice and reasonable proof, will re-attach those licenses and/or attributions. To all, peace and happiness.

  4. #4

    Thread Starter
    Member Dragokas's Avatar
    Join Date
    Aug 2015
    Location
    Ukraine
    Posts
    530

    Re: List of LCID by Font character set

    Hi, Eduardo !

    Thank you for that list, but, e.g. there are CHINESEBIG5_CHARSET and CHINESESIMPLIFIED_CHARSET (by the way it not listed in MSDN article),
    so I don't know what country from this list use first or second charset:
    Chinese - People's Republic of China
    Chinese - Singapore
    Chinese - Taiwan
    Chinese - Hong Kong SAR
    Chinese - Macao SAR
    Same for other countries. Ukraine uses Russian charset. e.t.c.

  5. #5

    Thread Starter
    Member Dragokas's Avatar
    Join Date
    Aug 2015
    Location
    Ukraine
    Posts
    530

    Re: List of LCID by Font character set

    Hi, Elroy!

    Thank you. I understand what you mean.

    I'll do it simplier.

    I hope that is correct test:

    Code:
    Private Const DEFAULT_CHARSET           As Long = 1&
    Private Const SYMBOL_CHARSET            As Long = 2&
    Private Const SHIFTJIS_CHARSET          As Long = 128&
    Private Const HANGEUL_CHARSET           As Long = 129&
    Private Const GB2312_CHARSET            As Long = &H86&
    Private Const CHINESEBIG5_CHARSET       As Long = 136&
    Private Const CHINESESIMPLIFIED_CHARSET As Long = 134&
    Private Const GREEK_CHARSET             As Long = &HA1&
    Private Const TURKISH_CHARSET           As Long = &HA2&
    Private Const HEBREW_CHARSET            As Long = &HB1&
    Private Const ARABIC_CHARSET            As Long = &HB2&
    Private Const BALTIC_CHARSET            As Long = &HBA&
    Private Const RUSSIAN_CHARSET           As Long = &HCC&
    Private Const THAI_CHARSET              As Long = &HDE&
    Private Const EE_CHARSET                As Long = &HEE&
    Private Const OEM_CHARSET               As Long = &HFF&
    
    Public Sub Test()
        Dim i As Long, j As Long
        Dim dDict As Object, Key As Variant
        Dim sFontName As String
        Dim lCharset As Long
        
        Set dDict = CreateObject("Scripting.Dictionary")
        
        'dDict.Add "DEFAULT_CHARSET", DEFAULT_CHARSET
        dDict.Add "SYMBOL_CHARSET", SYMBOL_CHARSET
        dDict.Add "SHIFTJIS_CHARSET", SHIFTJIS_CHARSET
        dDict.Add "HANGEUL_CHARSET", HANGEUL_CHARSET
        dDict.Add "GB2312_CHARSET", GB2312_CHARSET
        dDict.Add "CHINESEBIG5_CHARSET", CHINESEBIG5_CHARSET
        dDict.Add "CHINESESIMPLIFIED_CHARSET", CHINESESIMPLIFIED_CHARSET
        dDict.Add "GREEK_CHARSET", GREEK_CHARSET
        dDict.Add "TURKISH_CHARSET", TURKISH_CHARSET
        dDict.Add "HEBREW_CHARSET", HEBREW_CHARSET
        dDict.Add "ARABIC_CHARSET", ARABIC_CHARSET
        dDict.Add "BALTIC_CHARSET", BALTIC_CHARSET
        dDict.Add "RUSSIAN_CHARSET", RUSSIAN_CHARSET
        dDict.Add "THAI_CHARSET", THAI_CHARSET
        
        For i = 0 To Screen.FontCount - 1
            With Me.txtHelp
                sFontName = Screen.Fonts(i)
                .Font.Name = sFontName
                
                For Each Key In dDict.Keys
                    lCharset = dDict(Key)
                    
                    .Font.Charset = lCharset
                    
                    If .Font.Charset <> lCharset Then
                        Debug.Print "Font: " & sFontName & " doesn't support: " & Key
                    End If
                Next
            End With
        Next i
        Set dDict = Nothing
    End Sub
    Font: @Batang doesn't support: SYMBOL_CHARSET
    Font: @BatangChe doesn't support: SYMBOL_CHARSET
    Font: @Gungsuh doesn't support: SYMBOL_CHARSET
    Font: @GungsuhChe doesn't support: SYMBOL_CHARSET
    Font: @Gulim doesn't support: SYMBOL_CHARSET
    Font: @GulimChe doesn't support: SYMBOL_CHARSET
    Font: @Dotum doesn't support: SYMBOL_CHARSET
    Font: @DotumChe doesn't support: SYMBOL_CHARSET
    Font: @Malgun Gothic doesn't support: SYMBOL_CHARSET
    Font: @Meiryo doesn't support: SYMBOL_CHARSET
    Font: @Meiryo UI doesn't support: SYMBOL_CHARSET
    Font: @Microsoft JhengHei doesn't support: SYMBOL_CHARSET
    Font: @Microsoft YaHei doesn't support: SYMBOL_CHARSET
    Font: @MingLiU doesn't support: SYMBOL_CHARSET
    Font: @PMingLiU doesn't support: SYMBOL_CHARSET
    Font: @MingLiU_HKSCS doesn't support: SYMBOL_CHARSET
    Font: @MingLiU-ExtB doesn't support: SYMBOL_CHARSET
    Font: @PMingLiU-ExtB doesn't support: SYMBOL_CHARSET
    Font: @MingLiU_HKSCS-ExtB doesn't support: SYMBOL_CHARSET
    Font: @MS Gothic doesn't support: SYMBOL_CHARSET
    Font: @MS PGothic doesn't support: SYMBOL_CHARSET
    Font: @MS UI Gothic doesn't support: SYMBOL_CHARSET
    Font: @MS Mincho doesn't support: SYMBOL_CHARSET
    Font: @MS PMincho doesn't support: SYMBOL_CHARSET
    Font: @SimSun doesn't support: SYMBOL_CHARSET
    Font: @NSimSun doesn't support: SYMBOL_CHARSET
    Font: @SimSun-ExtB doesn't support: SYMBOL_CHARSET
    Font: Symbol doesn't support: SHIFTJIS_CHARSET
    Font: Symbol doesn't support: HANGEUL_CHARSET
    Font: Symbol doesn't support: GB2312_CHARSET
    Font: Symbol doesn't support: CHINESEBIG5_CHARSET
    Font: Symbol doesn't support: CHINESESIMPLIFIED_CHARSET
    Font: Symbol doesn't support: GREEK_CHARSET
    Font: Symbol doesn't support: TURKISH_CHARSET
    Font: Symbol doesn't support: HEBREW_CHARSET
    Font: Symbol doesn't support: ARABIC_CHARSET
    Font: Symbol doesn't support: BALTIC_CHARSET
    Font: Symbol doesn't support: RUSSIAN_CHARSET
    Font: Symbol doesn't support: THAI_CHARSET
    Font: @FangSong doesn't support: SYMBOL_CHARSET
    Font: @SimHei doesn't support: SYMBOL_CHARSET
    Font: @KaiTi doesn't support: SYMBOL_CHARSET
    Font: @DFKai-SB doesn't support: SYMBOL_CHARSET
    Font: @Arial Unicode MS doesn't support: SYMBOL_CHARSET
    (on Win7)

    That was an answer on one of my question:
    Also, is it possible to check if concrete font support concrete charset?
    Two questions left:
    What country which charset uses?
    Also, how to check is font unicode aware?

  6. #6

    Thread Starter
    Member Dragokas's Avatar
    Join Date
    Aug 2015
    Location
    Ukraine
    Posts
    530

    Re: List of LCID by Font character set

    Ahh, Elroy, I see.

    GetFontUnicodeRanges() function

    Quote Originally Posted by MSDN
    The GetFontUnicodeRanges function returns information about which Unicode characters are supported by a font. The information is returned as a GLYPHSET structure.
    So, some Font can partially support unicode or what? What is a best practice? If I would like to support in my program as much languages as possible, should I somehow search the font, that has maximum Unicode character range. Or there are no such "universal" font?

    EDIT.
    Does somebody know what is mean that "@" character before font name, e.g. "@MS Gothic" ?

  7. #7
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    4,496

    Re: List of LCID by Font character set

    Quote Originally Posted by Dragokas View Post
    Also, how to check is font unicode aware?
    You could just rework the code I posted in post #3. And any font that has a valid character larger that &hFF& is unicode aware.

    There's probably a faster way to do it, but that'd certainly work.

    Take Care,
    Elroy


    EDIT1: Something like...

    Code:
    
    Option Explicit
    
    Private Const TWIPSPERINCH = 1440
    Private Const HORZRES = 8
    Private Const VERTRES = 10
    Private Const LOGPIXELSX = 88
    Private Const LOGPIXELSY = 90
    
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    
    'used with fnWeight
    Private Const FW_DONTCARE = 0
    Private Const FW_THIN = 100
    Private Const FW_EXTRALIGHT = 200
    Private Const FW_LIGHT = 300
    Private Const FW_NORMAL = 400
    Private Const FW_MEDIUM = 500
    Private Const FW_SEMIBOLD = 600
    Private Const FW_BOLD = 700
    Private Const FW_EXTRABOLD = 800
    Private Const FW_HEAVY = 900
    Private Const FW_BLACK = FW_HEAVY
    Private Const FW_DEMIBOLD = FW_SEMIBOLD
    Private Const FW_REGULAR = FW_NORMAL
    Private Const FW_ULTRABOLD = FW_EXTRABOLD
    Private Const FW_ULTRALIGHT = FW_EXTRALIGHT
    
    'used with fdwCharSet
    Private Const ANSI_CHARSET = 0
    Private Const DEFAULT_CHARSET = 1
    Private Const SYMBOL_CHARSET = 2
    Private Const SHIFTJIS_CHARSET = 128
    Private Const HANGEUL_CHARSET = 129
    Private Const CHINESEBIG5_CHARSET = 136
    Private Const OEM_CHARSET = 255
    
    'used with fdwOutputPrecision
    Private Const OUT_CHARACTER_PRECIS = 2
    Private Const OUT_DEFAULT_PRECIS = 0
    Private Const OUT_DEVICE_PRECIS = 5
    
    'used with fdwClipPrecision
    Private Const CLIP_DEFAULT_PRECIS = 0
    Private Const CLIP_CHARACTER_PRECIS = 1
    Private Const CLIP_STROKE_PRECIS = 2
    
    'used with fdwQuality
    Private Const DEFAULT_QUALITY = 0
    Private Const DRAFT_QUALITY = 1
    Private Const PROOF_QUALITY = 2
    
    'used with fdwPitchAndFamily
    Private Const DEFAULT_PITCH = 0
    Private Const FIXED_PITCH = 1
    Private Const VARIABLE_PITCH = 2
    
    Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
    Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Boolean, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    
    Private Type WCRANGE
      wcLow As Integer   'Low Unicode code point in the range of supported Unicode code points.
      cGlyphs As Integer 'Number of supported Unicode code points in this range.
    End Type
    
    Private Type GLYPHSET
      cbThis As Long           'The size, in bytes, of this structure.
      flAccel As Long          'Flags describing the maximum size of the glyph indices.
      cGlyphsSupported As Long 'The total number of Unicode code points supported in the font.
      cRanges As Long          'The total number of Unicode ranges in ranges.
      aRANGE() As WCRANGE      'Array of Unicode ranges that are supported in the font.
    End Type
    
    Private Const GGI_MARK_NONEXISTING_GLYPHS As Long = &H1
    Private Const GDI_ERROR As Long = &HFFFFFFFF
    Private Const INVALIDGLYPHINDEX As Integer = &HFFFF
    
    Private Declare Function GetFontUnicodeRanges Lib "gdi32.dll" (ByVal hDC As Long, lpGS As Any) As Long
    Private Declare Function GetGlyphIndices Lib "gdi32.dll" Alias "GetGlyphIndicesA" (ByVal hDC As Long, ByVal lpStr As String, ByVal lpStrLen As Long, ByVal pGI As Long, ByVal Flags As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal nCount As Long)
    
    Sub Form_Click()
    
    
        MsgBox "Form's font, unicode aware: " & FontHasUnicode(Me.Font)
    
    End Sub
    
    Private Function FontHasUnicode(ByVal F As Font) As Boolean
        Dim GS As GLYPHSET
        Dim i As Long
        '
        GS = GetGLYPHSET(F)
        For i = &H100& To &HFFFF&
            If HuntGLYPHSET(i, GS) Then
                FontHasUnicode = True
                Exit Function
            End If
        Next
    End Function
    
    Private Function GetGLYPHSET(ByVal F As Font) As GLYPHSET
      'http://msdn.microsoft.com/en-us/library/windows/desktop/dd144887%28v=vs.85%29.aspx
      Dim Data() As Byte, i As Long, j As Long
      Dim Result As Long, Count As Long
      Dim GS As GLYPHSET
      Dim hDC As Long
    
      'Some of the propertys might not exists in the Font object
      On Error Resume Next
      Dim fSize As Integer, fBold As Integer
      Dim FName As String
      Dim fItalic As Boolean, fUnderline As Boolean, fStrikethrough As Boolean
      Dim hFont As Long, hOldFont As Long
      fSize = -MulDiv(F.Size, GetDeviceCaps(hDC, LOGPIXELSY), 72)
      FName = F.Name
      fBold = IIf(F.Bold, FW_BOLD, FW_NORMAL)
      fItalic = F.Italic
      fUnderline = F.Underline
      fStrikethrough = F.Strikethrough
      On Error GoTo 0
    
      'Create a device context compatible to the screen
      hDC = CreateCompatibleDC(GetDC(0&))
      If hDC = 0 Then Exit Function
      'Create font object
      hFont = CreateFont(fSize, 0, 0, 0, fBold, fItalic, fUnderline, fStrikethrough, _
        DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, _
        DEFAULT_PITCH, FName)
      If hFont = 0 Then Exit Function
      'Load the font into the device context, storing the original font object
      hOldFont = SelectObject(hDC, hFont)
    
      'Get the size of the GLYPHSET structure required to store the information
      Result = GetFontUnicodeRanges(hDC, ByVal 0&)
      If Result = 0 Then Exit Function
      ReDim Data(0 To (Result - 1)) As Byte
      'Get the data and the number of bytes written
      Result = GetFontUnicodeRanges(hDC, Data(LBound(Data)))
      If Result = 0 Then Exit Function
    
      'Coyp the first 4 LONG into the GLYPHSET structure
      i = LBound(Data)
      Count = 4 * 4
      CopyMemory GS, Data(i), Count
      i = i + Count
      With GS
        'Did the font support unicode?
        If .cRanges > 0 Then
          'Create the array of ranges and copy the data into there
          ReDim .aRANGE(0 To (.cRanges - 1)) As WCRANGE
          j = LBound(.aRANGE)
          Count = .cRanges
          Do While Count > 0
            CopyMemory .aRANGE(j), Data(i), Len(.aRANGE(j))
            i = i + Len(.aRANGE(j))
            j = j + 1
            Count = Count - 1
          Loop
        End If
      End With
      'Destroy the created objects and return results
      DeleteObject hFont
      DeleteDC hDC
      GetGLYPHSET = GS
    End Function
    
    Private Function HuntGLYPHSET(ByVal CharCode As Long, ByRef GS As GLYPHSET) As Boolean
      'Hunt through the GLYPHSET, True if the Unicode character is supported
      Dim i As Long, Low As Long
      With GS
        CharCode = CharCode + 1
        For i = 0 To .cRanges - 1
          With .aRANGE(i)
            If .wcLow < 0 Then
              Low = .wcLow And &HFFFF&
            Else
              Low = .wcLow
            End If
            If CharCode > Low Then
              If CharCode <= Low + .cGlyphs Then
                HuntGLYPHSET = True
                Exit Function
              End If
            End If
          End With
        Next
      End With
    End Function
    
    
    
    
    Last edited by Elroy; Aug 12th, 2018 at 01:21 PM.
    Any software I post in these forums written by me is provided “AS IS” without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. Please understand that I’ve been programming since the mid-1970s and still have some of that code. My contemporary VB6 project is approaching 1,000 modules. In addition, I have a “VB6 random code folder” that is overflowing. I’ve been at this long enough to truly not know with absolute certainty from whence every single line of my code has come, with much of it coming from programmers under my employ who signed intellectual property transfers. I have not deliberately attempted to remove any licenses and/or attributions from any software. If someone finds that I have inadvertently done so, I sincerely apologize, and, upon notice and reasonable proof, will re-attach those licenses and/or attributions. To all, peace and happiness.

  8. #8
    Fanatic Member DrUnicode's Avatar
    Join Date
    Mar 2008
    Location
    Natal, Brazil
    Posts
    605

    Re: List of LCID by Font character set

    Does somebody know what is mean that "@" character before font name, e.g. "@MS Gothic" ?
    Fonts which begin with an @-sign are vertically-oriented fonts. They are used in languages like Chinese, Japanese, and (less often) Korean. The idea is that if you want to generate vertical text, you start with the horizontal version of the font and compose your document, then switch to the vertical version for printing.

  9. #9
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    4,496

    Re: List of LCID by Font character set

    Quote Originally Posted by Dragokas View Post
    So, some Font can partially support unicode or what?
    I'm not the expert here, but I do have some experience with it.

    I've got no idea how font creators decide which characters to create and which to ignore. Just upon casual observation, it seems somewhat haphazard.

    The only thing I'd know to do is to identify a language, identify all the characters in that language, and then see if a specific font has all those characters.

    Also, there might be a way to take a particular LCID and get its character-set. Then, you could check to see if a particular font has all those characters. However, I don't know how to get the characters for a specific LCID. I could tell you what they are for American-English.

    Good Luck,
    Elroy
    Any software I post in these forums written by me is provided “AS IS” without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. Please understand that I’ve been programming since the mid-1970s and still have some of that code. My contemporary VB6 project is approaching 1,000 modules. In addition, I have a “VB6 random code folder” that is overflowing. I’ve been at this long enough to truly not know with absolute certainty from whence every single line of my code has come, with much of it coming from programmers under my employ who signed intellectual property transfers. I have not deliberately attempted to remove any licenses and/or attributions from any software. If someone finds that I have inadvertently done so, I sincerely apologize, and, upon notice and reasonable proof, will re-attach those licenses and/or attributions. To all, peace and happiness.

  10. #10

    Thread Starter
    Member Dragokas's Avatar
    Join Date
    Aug 2015
    Location
    Ukraine
    Posts
    530

    Re: List of LCID by Font character set

    Elroy and DrUnicode, thank you.

    --
    Just to slightly warm up the topic: msdn.microsoft.com/en-us/library/aa241713(v=vs.60).aspx

    Code:
    Private Const DEFAULT_CHARSET = 1
    Private Const SYMBOL_CHARSET = 2
    Private Const SHIFTJIS_CHARSET = 128
    Private Const HANGEUL_CHARSET = 129
    Private Const CHINESEBIG5_CHARSET = 136
    Private Const CHINESESIMPLIFIED_CHARSET = 134
    Private Declare Function GetUserDefaultLCID Lib "kernel32" () As Long
    
    Public Sub SetProperFont(obj As Object)
        On Error GoTo ErrorSetProperFont
        Select Case GetUserDefaultLCID
        Case &H404 ' Traditional Chinese
            obj.Charset = CHINESEBIG5_CHARSET
            obj.Name = ChrW(&H65B0) + ChrW(&H7D30) + ChrW(&H660E) _
             + ChrW(&H9AD4)   'New Ming-Li
            obj.Size = 9
        Case &H411 ' Japan
            obj.Charset = SHIFTJIS_CHARSET
            obj.Name = ChrW(&HFF2D) + ChrW(&HFF33) + ChrW(&H20) + _
             ChrW(&HFF30) + ChrW(&H30B4) + ChrW(&H30B7) + ChrW(&H30C3) + _
             ChrW(&H30AF)
            obj.Size = 9
        Case &H412 'Korea UserLCID
            obj.Charset = HANGEUL_CHARSET
            obj.Name = ChrW(&HAD74) + ChrW(&HB9BC)
            obj.Size = 9
        Case &H804 ' Simplified Chinese
            obj.Charset = CHINESESIMPLIFIED_CHARSET
            obj.Name = ChrW(&H5B8B) + ChrW(&H4F53)
            obj.Size = 9
        Case Else   ' The other countries
            obj.Charset = DEFAULT_CHARSET
            obj.Name = ""   ' Get the default UI font.
            obj.Size = 8
        End Select
        Exit Sub
    ErrorSetProperFont:
        Err.Number = Err
    End Sub

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width