-
Aug 12th, 2018, 11:58 AM
#1
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.
-
Aug 12th, 2018, 12:24 PM
#2
Re: List of LCID by Font character set
Hello. Not sure if this list of LCID's can help.
-
Aug 12th, 2018, 12:35 PM
#3
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. To all, peace and happiness.
-
Aug 12th, 2018, 12:54 PM
#4
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.
-
Aug 12th, 2018, 01:08 PM
#5
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?
-
Aug 12th, 2018, 01:16 PM
#6
Re: List of LCID by Font character set
Ahh, Elroy, I see.
GetFontUnicodeRanges() function
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" ?
-
Aug 12th, 2018, 01:17 PM
#7
Re: List of LCID by Font character set
Originally Posted by Dragokas
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. To all, peace and happiness.
-
Aug 12th, 2018, 01:34 PM
#8
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.
-
Aug 12th, 2018, 01:44 PM
#9
Re: List of LCID by Font character set
Originally Posted by Dragokas
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. To all, peace and happiness.
-
Aug 12th, 2018, 01:46 PM
#10
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
-
Sep 30th, 2022, 12:25 PM
#11
Addicted Member
Re: List of LCID by Font character set
Originally Posted by Elroy
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
Hi Elroy.
Nice code ! and well commented but I am finding it difficult to understand the HuntGLYPHSET routine:
Code:
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
The WCRANGE structure is not well documented.
-
Oct 5th, 2022, 02:51 AM
#12
Banned
Re: List of LCID by Font character set
Some Basic Ones
charset=big5 - Chinese Traditional (Big5)
charset=euc-kr - Korean (EUC)
charset=iso-8859-1 - Western Alphabet
charset=iso-8859-2 - Central European Alphabet (ISO)
charset=iso-8859-3 - Latin 3 Alphabet (ISO)
charset=iso-8859-4 - Baltic Alphabet (ISO)
charset=iso-8859-5 - Cyrillic Alphabet (ISO)
charset=iso-8859-6 - Arabic Alphabet (ISO)
charset=iso-8859-7 - Greek Alphabet (ISO)
charset=iso-8859-8 - Hebrew Alphabet (ISO)
charset=koi8-r - Cyrillic Alphabet (KOI8-R)
charset=shift-jis - Japanese (Shift-JIS)
charset=x-euc - Japanese (EUC)
charset=utf-8 - Universal Alphabet (UTF-8)
charset=windows-1250 - Central European Alphabet (Windows)
charset=windows-1251 - Cyrillic Alphabet (Windows)
charset=windows-1252 - Western Alphabet (Windows)
charset=windows-1253 - Greek Alphabet (Windows)
charset=windows-1254 - Turkish Alphabet
charset=windows-1255 - Hebrew Alphabet (Windows)
charset=windows-1256 - Arabic Alphabet (Windows)
charset=windows-1257 - Baltic Alphabet (Windows)
charset=windows-1258 - Vietnamese Alphabet (Windows)
charset=windows-874 - Thai (Windows)
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|