dcsimg
Results 1 to 6 of 6

Thread: [RESOLVED] glyphs availability on font Tahoma

  1. #1

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2017
    Posts
    1,685

    Resolved [RESOLVED] glyphs availability on font Tahoma

    I used some glyphs (characters) that are available in the font Tahoma in Windows 10, but when I tested on XP I found that they were missing.
    I already found another font (Lucida Sans Unicode) with glyphs similar to the ones I need that are available in XP, but they are not exactly the same and I would like to stick to my original Tahoma glyphs when they are available.

    I found some information about the font here, but not exactly what glyphs are available and which ones not on each version.

    What I am asking is if you have Windows 7 (or Windows Vista) to run the following code and tell me if the glyphs are available or not:

    Code:
    Private Declare Function TextOut Lib "gdi32" Alias "TextOutW" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As Long, ByVal nCount As Long) As Long
    
    Private Sub Form_Load()
        Me.AutoRedraw = True
        Me.FontName = "Tahoma"
        Me.FontSize = 16
        
        ' hamburger icon
        Me.CurrentX = 1000
        Me.ForeColor = vbBlue
        PrintText "hamburger icon: "
        Me.CurrentX = 2000
        Me.ForeColor = vbBlack
        PrintText ChrW(&H2630&)
        
        ' vertical ellipsis
        Me.CurrentX = 1000
        Me.ForeColor = vbBlue
        PrintText "vertical ellipsis:  "
        Me.CurrentX = 2000
        Me.ForeColor = vbBlack
        PrintText ChrW(&H205D&)
        
        ' horizonal ellipsis
        Me.CurrentX = 1000
        Me.ForeColor = vbBlue
        PrintText "horizontal ellipsis: "
        Me.CurrentX = 2000
        Me.ForeColor = vbBlack
        PrintText ChrW(&H2027&) & ChrW(&H2027&) & ChrW(&H2027&)
        
    End Sub
    
    Private Sub PrintText(nText As String)
        TextOut Me.hdc, Me.CurrentX / Screen.TwipsPerPixelX, Me.CurrentY / Screen.TwipsPerPixelY, StrPtr(nText), Len(nText)
        Me.CurrentY = Me.CurrentY + Me.TextHeight("A")
    End Sub
    Thank you!

    Result on XP:
    Name:  WinXP.png
Views: 105
Size:  11.9 KB

    Result on Windows 10:
    Name:  Win10.png
Views: 100
Size:  7.8 KB
    Last edited by Eduardo-; May 21st, 2019 at 01:17 AM.

  2. #2
    Hyperactive Member
    Join Date
    Feb 2019
    Posts
    306

    Re: glyphs availability on font Tahoma

    Windows 7 Pro+SP1 and all updates(as of March 20, 2019):

    Name:  TahomaFont1.png
Views: 75
Size:  11.6 KB

  3. #3

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2017
    Posts
    1,685

    Re: glyphs availability on font Tahoma

    Thank you very much qvb6

    I see that the vertical ellipsis is not available still in Windows 7.
    Last edited by Eduardo-; May 21st, 2019 at 01:16 AM.

  4. #4
    PowerPoster
    Join Date
    Jun 2013
    Posts
    4,239

    Re: [RESOLVED] glyphs availability on font Tahoma

    FWIW, here's my results for Win 8.1:



    And here the original test-code (with a small addition, which should work anywhere):
    Code:
    Option Explicit
    
    Private Declare Function TextOut Lib "gdi32" Alias "TextOutW" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As Long, ByVal nCount As Long) As Long
    
    Private Sub Form_Load()
        Me.AutoRedraw = True
        Me.FontName = "Tahoma"
        Me.FontSize = 16
        
        ' hamburger icon
        Me.CurrentX = 1000
        Me.ForeColor = vbBlue
        PrintText "hamburger icon: "
        Me.CurrentX = 2000
        Me.ForeColor = vbBlack
        PrintText ChrW(&H2630&)
        
        ' vertical ellipsis
        Me.CurrentX = 1000
        Me.ForeColor = vbBlue
        PrintText "vertical ellipsis:  "
        Me.CurrentX = 2000
        Me.ForeColor = vbBlack
        PrintText ChrW(&H205D&)
        
        ' horizonal ellipsis
        Me.CurrentX = 1000
        Me.ForeColor = vbBlue
        PrintText "horizontal ellipsis: "
        Me.CurrentX = 2000
        Me.ForeColor = vbBlack
        PrintText ChrW(&H2027&) & ChrW(&H2027&) & ChrW(&H2027&)
        
        'workaround for systems without the full glyph-set
        Me.CurrentX = 1000
        Me.ForeColor = vbBlue
        PrintText "TextOut-renderings for the poor: "
        Me.CurrentX = 2000
        Me.ForeColor = vbBlack
        Me.FontSize = 17
        
        'the |_| stuff, just to show another "Text-Cell" on the current line,
        'to get a better impression about the placements of the prior renderoutput
        PrintBullets True, False:  PrintText "   |_|"
        PrintBullets False, False: PrintText "   |_|"
        PrintBullets True, True:   PrintText "   |_|"
        PrintBullets False, True:  PrintText "   |_|"
    End Sub
    
    Private Sub PrintText(nText As String)
        TextOut Me.hdc, Me.CurrentX / Screen.TwipsPerPixelX, Me.CurrentY / Screen.TwipsPerPixelY, StrPtr(nText), Len(nText)
        Me.CurrentY = Me.CurrentY + Me.TextHeight("A")
    End Sub
    
    Sub PrintBullets(Optional ByVal Vertical As Boolean, Optional ByVal AsHamburger As Boolean)
      Dim x, y, dx, dy, i, j
      dx = Int(Me.TextWidth(".") / Screen.TwipsPerPixelX)
      If Vertical Then dy = dx: dx = 0
      x = Me.CurrentX / Screen.TwipsPerPixelX + dy * 0.7 - dx * 0.25
      y = Me.CurrentY / Screen.TwipsPerPixelY - dx * 0.7 + dy * 0.25
      
      For i = 0 To 2: For j = IIf(AsHamburger, 4, 0) To IIf(AsHamburger, -4, 0) Step -1
        TextOut Me.hdc, Int(x + i * dx + j * dy / 4), Int(y - i * dy - j * dx / 4), StrPtr("."), 1
      Next j, i
    End Sub
    Olaf

  5. #5

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2017
    Posts
    1,685

    Re: [RESOLVED] glyphs availability on font Tahoma

    Thank you.
    I'm using the glyphs in a control, the TextOut was only for this program intended to be useful to easily test.

    But anyway this helped me, because I assumed that the last version of the font was first shipped with Windows 8. According to the MS page I understood that, but now I see that even in Windows 8.1 the glyph of the vertical ellipsis is not still present.

    Now I have the doubt when it was added, in what Windows 10 version it was added.

  6. #6

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2017
    Posts
    1,685

    Re: [RESOLVED] glyphs availability on font Tahoma

    Finally I was able to check whether the glyph exists in the font based in code from Elroy that I found here:

    Code:
    Option Explicit
    
    Private Type WCRANGE
        wcLow As Integer
        cGlyphs As Integer
    End Type
    
    Private Type GLYPHSET
        cbThis As Long
        flAccel As Long
        cGlyphsSupported As Long
        cRanges As Long
        ranges() As WCRANGE
    End Type
    
    Private Declare Function GetFontUnicodeRanges Lib "gdi32.dll" (ByVal hDC As Long, lpGS As Any) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal nCount As Long)
    Private Declare Function GetDC 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
    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 Const LOGPIXELSY = 90
    Private Const FW_NORMAL = 400
    Private Const FW_BOLD = 700
    Private Const DEFAULT_CHARSET = 1
    Private Const OUT_DEFAULT_PRECIS = 0
    Private Const CLIP_DEFAULT_PRECIS = 0
    Private Const DEFAULT_QUALITY = 0
    Private Const DEFAULT_PITCH = 0
    
    Public Function FontHasCharacter(ByVal F As Font, nAscW As Long) As Boolean
        Dim GS As GLYPHSET
        
        GS = GetGLYPHSET(F)
        FontHasCharacter = CharSupportedInGlyphSet(nAscW, GS)
    End Function
    
    Private Function GetGLYPHSET(ByVal F As Font) As GLYPHSET
        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
        Dim hDC0 As Long
        
        hDC0 = GetDC(0&)
        hDC = CreateCompatibleDC(hDC0)
        ReleaseDC 0&, hDC0
        If hDC = 0 Then Exit Function
        
        '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 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 .ranges(0 To (.cRanges - 1)) As WCRANGE
                j = LBound(.ranges)
                Count = .cRanges
                Do While Count > 0
                    CopyMemory .ranges(j), Data(i), Len(.ranges(j))
                    i = i + Len(.ranges(j))
                    j = j + 1
                    Count = Count - 1
                Loop
            End If
        End With
        'Destroy the created objects and return results
        hOldFont = SelectObject(hDC, hOldFont)
        DeleteObject hFont
        DeleteDC hDC
        GetGLYPHSET = GS
    End Function
    
    Private Function CharSupportedInGlyphSet(ByVal CharCode As Long, ByRef GS As GLYPHSET) As Boolean
        Dim i As Long, Low As Long
        
        With GS
            CharCode = CharCode + 1
            For i = 0 To .cRanges - 1
                With .ranges(i)
                    If .wcLow < 0 Then
                        Low = .wcLow And &HFFFF&
                    Else
                        Low = .wcLow
                    End If
                    If CharCode > Low Then
                        If CharCode <= Low + .cGlyphs Then
                            CharSupportedInGlyphSet = True
                            Exit Function
                        End If
                    End If
                End With
            Next
        End With
    End Function

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