Private Const HEBREW_CHARSET As Long = &HB1& Private Const TURKISH_CHARSET As Long = &HA2& Private Const GREEK_CHARSET As Long = &HA1& Private Const CHINESESIMPLIFIED_CHARSET As Long = 134& Private Const CHINESEBIG5_CHARSET As Long = 136& Private Const GB2312_CHARSET As Long = &H86&
Private Const HANGEUL_CHARSET As Long = 129& Private Const SHIFTJIS_CHARSET As Long = 128& Private Const SYMBOL_CHARSET As Long = 2& It'll be interesting to see how this thread progresses.Ĭode: Private Const DEFAULT_CHARSET As Long = 1& Although I'm not finding a great many of them developed for VB6. There also seem to be several other API calls to get information on fonts ( ). 'Destroy the created objects and return resultsĮnd 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 aRANGE (j ), Data (i ), Len (.aRANGE (j ) ) aRANGE (0 To (.cRanges - 1 ) ) As WCRANGEĬopyMemory. 'Create the array of ranges and copy the data into there ReDim.
GS = GetGLYPHSET (Me.Font ) 'Write the headingsĭebug.Print "Nr Unicode Char" 'Create the output 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 Private Const INVALIDGLYPHINDEX As Integer = &HFFFF Private Const GDI_ERROR As Long = &HFFFFFFFF End Type Private Const GGI_MARK_NONEXISTING_GLYPHS As Long = &H1
End Type Private Type GLYPHSETĬbThis As Long 'The size, in bytes, of this structure.įlAccel As Long 'Flags describing the maximum size of the glyph indices.ĬGlyphsSupported As Long 'The total number of Unicode code points supported in the font.ĬRanges As Long 'The total number of Unicode ranges in ranges.ĪRANGE ( ) As WCRANGE 'Array of Unicode ranges that are supported in the font. WcLow As Integer 'Low Unicode code point in the range of supported Unicode code points.ĬGlyphs As Integer 'Number of supported Unicode code points in this range. 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 'used with fdwPitchAndFamily Private Const DEFAULT_PITCH = 0 'used with fdwQuality Private Const DEFAULT_QUALITY = 0 'used with fdwClipPrecision Private Const CLIP_DEFAULT_PRECIS = 0 'used with fdwOutputPrecision Private Const OUT_CHARACTER_PRECIS = 2 'used with fdwCharSet Private Const ANSI_CHARSET = 0 Private Const FW_ULTRALIGHT = FW_EXTRALIGHT Private Const FW_ULTRABOLD = FW_EXTRABOLD 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
Code: Option Explicit Private Const TWIPSPERINCH = 1440