vbAccelerator - Contents of code file: Test270Font_mFontAPI.bas

Attribute VB_Name = "mFontAPI"
Option Explicit

Public Type RECT
   left As Long
   top As Long
   right As Long
   bottom As Long
End Type

Private Type OSVERSIONINFO
   dwVersionInfoSize As Long
   dwMajorVersion As Long
   dwMinorVersion As Long
   dwBuildNumber As Long
   dwPlatformId As Long
   szCSDVersion(0 To 127) As Byte
End Type
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA"
 (lpVersionInfo As OSVERSIONINFO) As Long
Private Const VER_PLATFORM_WIN32_NT = 2

Public Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal
 hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Public Declare Function DrawTextA Lib "user32" (ByVal hDC As Long, ByVal lpStr
 As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Public Declare Function DrawTextW Lib "user32" (ByVal hDC As Long, ByVal lpStr
 As Long, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Public Const DT_LEFT = &H0&
    Public Const DT_TOP = &H0&
    Public Const DT_CENTER = &H1&
    Public Const DT_RIGHT = &H2&
    Public Const DT_VCENTER = &H4&
    Public Const DT_BOTTOM = &H8&
    Public Const DT_WORDBREAK = &H10&
    Public Const DT_SINGLELINE = &H20&
    Public Const DT_EXPANDTABS = &H40&
    Public Const DT_TABSTOP = &H80&
    Public Const DT_NOCLIP = &H100&
    Public Const DT_EXTERNALLEADING = &H200&
    Public Const DT_CALCRECT = &H400&
    Public Const DT_NOPREFIX = &H800
    Public Const DT_INTERNAL = &H1000&
    Public Const DT_WORD_ELLIPSIS = &H40000


Private Const LF_FACESIZE = 32
Public Type LOGFONT
    lfHeight As Long ' The font size (see below)
    lfWidth As Long ' Normally you don't set this, just let Windows create the
     default
    lfEscapement As Long ' The angle, in 0.1 degrees, of the font
    lfOrientation As Long ' Leave as default
    lfWeight As Long ' Bold, Extra Bold, Normal etc
    lfItalic As Byte ' As it says
    lfUnderline As Byte ' As it says
    lfStrikeOut As Byte ' As it says
    lfCharSet As Byte ' As it says
    lfOutPrecision As Byte ' Leave for default
    lfClipPrecision As Byte ' Leave for default
    lfQuality As Byte ' Leave as default (see end of article)
    lfPitchAndFamily As Byte ' Leave as default (see end of article)
    lfFaceName(LF_FACESIZE) As Byte ' The font name converted to a byte array
End Type
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
        ByVal hDC As Long, ByVal nIndex As Long _
    ) As Long
    Private Const LOGPIXELSX = 88 ' Logical pixels/inch in X
    Private Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
Private Declare Function MulDiv Lib "kernel32" ( _
    ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long
     _
    ) As Long
Public Declare Function CreateFontIndirect Lib "gdi32" Alias
 "CreateFontIndirectA" ( _
        lpLogFont As LOGFONT _
    ) As Long
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const FF_DONTCARE = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const DEFAULT_CHARSET = 1
Private Declare Function SetGraphicsMode Lib "gdi32" _
   (ByVal hDC As Long, ByVal iMode As Long) As Long
Private Const GM_ADVANCED = 2

Private m_bIsXp As Boolean
Private m_bIsNt As Boolean
Private m_bHasGradientAndTransparency As Boolean

Public Sub DrawText( _
      ByVal lhDC As Long, _
      ByVal sText As String, _
      ByVal lLength As Long, _
      tR As RECT, _
      ByVal lFlags As Long _
   )
Dim lPtr As Long
   If (m_bIsNt) Then
      lPtr = StrPtr(sText)
      If Not (lPtr = 0) Then ' NT4 crashes with ptr = 0
         DrawTextW lhDC, lPtr, -1, tR, lFlags
      End If
   Else
      DrawTextA lhDC, sText, -1, tR, lFlags
   End If
End Sub

Public Sub OLEFontToLogFont(fntThis As StdFont, hDC As Long, tLF As LOGFONT)
Dim sFont As String
Dim iChar As Integer

    ' Convert an OLE StdFont to a LOGFONT structure:
    With tLF
        sFont = fntThis.Name
        ' There is a quicker way involving StrConv and CopyMemory, but
        ' this is simpler!:
        For iChar = 1 To Len(sFont)
            .lfFaceName(iChar - 1) = CByte(Asc(Mid$(sFont, iChar, 1)))
        Next iChar
        ' Based on the Win32SDK documentation:
        .lfHeight = -MulDiv((fntThis.Size), (GetDeviceCaps(hDC, LOGPIXELSY)),
         72)
        .lfItalic = fntThis.Italic
        If (fntThis.Bold) Then
            .lfWeight = FW_BOLD
        Else
            .lfWeight = FW_NORMAL
        End If
        .lfUnderline = fntThis.Underline
        .lfStrikeOut = fntThis.Strikethrough
        ' Fix to ensure the correct character set is selected. Otherwise you
        ' cannot display Wingdings or international fonts:
        .lfCharSet = fntThis.Charset
        
    End With

End Sub


Public Sub VerInitialise()
   
   Dim tOSV As OSVERSIONINFO
   tOSV.dwVersionInfoSize = Len(tOSV)
   GetVersionEx tOSV
   
   m_bIsNt = ((tOSV.dwPlatformId And VER_PLATFORM_WIN32_NT) =
    VER_PLATFORM_WIN32_NT)
   If (tOSV.dwMajorVersion > 5) Then
      m_bHasGradientAndTransparency = True
      m_bIsXp = True
   ElseIf (tOSV.dwMajorVersion = 5) Then
      m_bHasGradientAndTransparency = True
      If (tOSV.dwMinorVersion >= 1) Then
         m_bIsXp = True
      End If
   ElseIf (tOSV.dwMajorVersion = 4) Then ' NT4 or 9x/ME/SE
      If (tOSV.dwMinorVersion >= 10) Then
         m_bHasGradientAndTransparency = True
      End If
   End If
   
End Sub

Public Property Get IsXp() As Boolean
   IsXp = m_bIsXp
End Property
Public Property Get IsNt() As Boolean
   IsNt = m_bIsNt
End Property
Public Property Get HasGradientAndTransparency()
   HasGradientAndTransparency = m_bHasGradientAndTransparency
End Property