vbAccelerator - Contents of code file: mCommandBarUtility.bas

Attribute VB_Name = "mCommandBarUtility"
Option Explicit


Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As
 Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As
 Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As
 Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal
 hWnd As Long, ByVal lpString As String) As Long

Private Const CTLOBJECTPOINTERPROPNAME As String = "vbalCommandBar:Control"

Public Const COMMANDBARSIZESTYLEMENU As Long = 1
Public Const COMMANDBARSIZESTYLEMENUVISIBLECHECK As Long = 2
Public Const COMMANDBARSIZESTYLETOOLBARMENU As Long = 3
Public Const COMMANDBARSIZESTYLETOOLBAR As Long = 4
Public Const COMMANDBARSIZESTYLETOOLBARWRAPPABLE As Long = 5

Public Const CHANGENOTIFICATIONBARCONTENTCHANGE = 1
Public Const CHANGENOTIFICATIONBARTITLECHANGE = 3
Public Const CHANGENOTIFICATIONBUTTONSIZECHANGE = 4
Public Const CHANGENOTIFICATIONBUTTONREDRAW = 5
Public Const CHANGENOTIFICATIONBUTTONCHECKCHANGE = 6

Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR
 As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Public Const CLR_INVALID = -1
Public Const CLR_NONE = CLR_INVALID
Private Declare Function GetVersion Lib "kernel32" () As Long

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

Private Type TRIVERTEX
   x As Long
   y As Long
   Red As Integer
   Green As Integer
   Blue As Integer
   Alpha As Integer
End Type
Private Type GRADIENT_RECT
    UpperLeft As Long
    LowerRight As Long
End Type
Private Type GRADIENT_TRIANGLE
    Vertex1 As Long
    Vertex2 As Long
    Vertex3 As Long
End Type
Private Declare Function GradientFill Lib "msimg32" ( _
   ByVal hDC As Long, _
   pVertex As TRIVERTEX, _
   ByVal dwNumVertex As Long, _
   pMesh As GRADIENT_RECT, _
   ByVal dwNumMesh As Long, _
   ByVal dwMode As Long) As Long
Private Declare Function GradientFillTriangle Lib "msimg32" Alias
 "GradientFill" ( _
   ByVal hDC As Long, _
   pVertex As TRIVERTEX, _
   ByVal dwNumVertex As Long, _
   pMesh As GRADIENT_TRIANGLE, _
   ByVal dwNumMesh As Long, _
   ByVal dwMode As Long) As Long
Private Const GRADIENT_FILL_TRIANGLE = &H2&

Public Enum GradientFillRectType
   GRADIENT_FILL_RECT_H = 0
   GRADIENT_FILL_RECT_V = 1
End Enum

Public Declare Function ImageList_GetImageRect Lib "comctl32.dll" ( _
        ByVal hIml As Long, _
        ByVal i As Long, _
        prcImage As RECT _
    ) As Long
Public Declare Function ImageList_Draw Lib "comctl32.dll" ( _
        ByVal hIml As Long, ByVal i As Long, _
        ByVal hdcDst As Long, ByVal x As Long, ByVal y As Long, _
        ByVal fStyle As Long _
    ) As Long
Private Const ILD_NORMAL = 0
Private Const ILD_TRANSPARENT = 1
Private Const ILD_BLEND25 = 2
Private Const ILD_SELECTED = 4
Private Const ILD_FOCUS = 4
Private Const ILD_MASK = &H10&
Private Const ILD_IMAGE = &H20&
Private Const ILD_ROP = &H40&
Private Const ILD_OVERLAYMASK = 3840
Private Const ILC_COLOR = &H0
Private Const ILC_COLOR32 = &H20
Private Const ILC_MASK = &H1&

Public Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal x As
 Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Public Declare Function LineTo Lib "gdi32" (ByVal hDC As Long, ByVal x As Long,
 ByVal y As Long) As Long

Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long,
 lpPoint As POINTAPI) As Long

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 TagControl(ByVal hWnd As Long, ByRef ctl As vbalCommandBar, ByVal
 state As Boolean)
   If (state) Then
      SetProp hWnd, CTLOBJECTPOINTERPROPNAME, ObjPtr(ctl)
   Else
      RemoveProp hWnd, CTLOBJECTPOINTERPROPNAME
   End If
End Sub

Public Function ControlFromhWnd(ByVal hWnd As Long, ByRef ctl As
 vbalCommandBar) As Boolean
   Dim lPtr As Long
   If Not (hWnd = 0) Then
      If IsWindow(hWnd) Then
         lPtr = GetProp(hWnd, CTLOBJECTPOINTERPROPNAME)
         If Not (lPtr = 0) Then
            Set ctl = ObjectFromPtr(lPtr)
            ControlFromhWnd = True
            Exit Function
         End If
      End If
   End If
   gErr 2

End Function

Public Sub gErr(ByVal lErr As Long)
Dim sDesc As String
Dim lErrNum As Long
Const lBase As Long = vbObjectError + 25260

   Select Case lErr
   Case 1
      ' Cannot find owner object
      lErrNum = 364
      sDesc = "Object has been unloaded."
   Case 2
      ' Bar does not exist
      lErrNum = lBase + lErr
      sDesc = "Owning Picker Control does not exist."
      
   Case 3
      ' Item does not exist
      lErrNum = lBase + lErr
      sDesc = "Item does not exist."
      
   Case 4
      ' Invalid key: numeric
      lErrNum = 13
      sDesc = "Type Mismatch."
      
   Case 5
      ' Invalid Key: duplicate
      lErrNum = 457
      sDesc = "This key is already associated with an element of this
       collection."
   
   Case 6
      ' Subscript out of range
      lErrNum = 9
      sDesc = "Subscript out of range."
   
   Case 7
      lErrNum = lBase + lErr
      sDesc = "Failed to add the item"
   
   Case Else
      Debug.Assert "Unexpected Error" = ""
      lErrNum = lErr + vbObjectError
   End Select
   
   
   Err.Raise lErrNum, App.EXEName & ".vbalPicker", sDesc
   
End Sub

Public Property Get ObjectFromPtr(ByVal lPtr As Long) As Object
Dim objT As Object
   If Not (lPtr = 0) Then
      ' Turn the pointer into an illegal, uncounted interface
      CopyMemory objT, lPtr, 4
      ' Do NOT hit the End button here! You will crash!
      ' Assign to legal reference
      Set ObjectFromPtr = objT
      ' Still do NOT hit the End button here! You will still crash!
      ' Destroy the illegal reference
      CopyMemory objT, 0&, 4
   End If
End Property

Public Function CollectionContains(col As Collection, ByVal Key As String) As
 Boolean
Dim v As Variant
Dim lErr As Long
   On Error Resume Next
   v = col(Key)
   lErr = Err.Number
   On Error GoTo 0
   CollectionContains = (lErr = 0)
End Function

Public Sub UtilDrawIcon( _
      ByVal hDC As Long, _
      ByVal hIml As Long, _
      ByVal ptrVB6Iml As Long, _
      ByVal iconIndex As Long, _
      ByVal iconX As Long, _
      ByVal iconY As Long, _
      ByVal Enabled As Boolean _
   )
Dim lFlags As Long
Dim lR As Long

         ' Just for fun, there's also a magic hack here.
         ' If the icon is negative and < -1 then we draw
         ' a colour block.  Don't tell your mum!
   If (iconIndex < -1) Then
      Dim tR As RECT
      Dim hBr As Long
      
      tR.left = iconX + 1
      tR.top = iconX + 1
      tR.bottom = tR.top + 14
      tR.right = tR.left + 14
      hBr = CreateSolidBrush(Abs(iconIndex))
      FillRect hDC, tR, hBr
      DeleteObject hBr
      
      ' outline:
      UtilDrawBorderRectangle hDC, tR.left, tR.top, tR.right - tR.left,
       tR.bottom - tR.top
      
   Else
      ' TODO: We need to provide disabled images
      
      lFlags = ILD_TRANSPARENT
      If Not (ptrVB6Iml = 0) Then
         Dim o As Object
         On Error Resume Next
         Set o = ObjectFromPtr(ptrVB6Iml)
         If Not (o Is Nothing) Then
             o.ListImages(iconIndex + 1).Draw hDC, iconX, iconY, lFlags
         End If
         On Error GoTo 0
      Else
         ImageList_Draw _
             hIml, _
             iconIndex, _
             hDC, _
             iconX, _
             iconY, _
             lFlags
      End If
   End If
   
End Sub

Public Sub UtilDrawBorderRectangle( _
      ByVal hDC As Long, _
      ByVal left As Long, _
      ByVal top As Long, _
      ByVal width As Long, _
      ByVal Height As Long _
   )
Dim tJ As POINTAPI
Dim hPen As Long
Dim hPenOld As Long
   
   hPen = CreatePen(PS_SOLID, 1, MenuBorderColor)
   hPenOld = SelectObject(hDC, hPen)
   MoveToEx hDC, left, top + Height - 1, tJ
   LineTo hDC, left, top
   LineTo hDC, left + width - 1, top
   LineTo hDC, left + width - 1, top + Height - 1
   LineTo hDC, left, top + Height - 1
   SelectObject hDC, hPenOld
   DeleteObject hPen

End Sub

Public Sub UtilDrawText( _
      ByVal hDC As Long, _
      ByVal sCaption As String, _
      ByVal lTextX As Long, _
      ByVal lTextY As Long, _
      ByVal lTextWidth As Long, _
      ByVal lTextHeight As Long, _
      ByVal bEnabled As Boolean, _
      ByVal color As Long, _
      ByVal orientation As ECommandBarOrientation _
   )
Dim tR As RECT
Dim lFlags As Long
   
   If (orientation = eBottom) Or (orientation = eTop) Then
      tR.left = lTextX
      tR.top = lTextY
      tR.right = lTextX + lTextWidth
      tR.bottom = lTextY + lTextHeight
      lFlags = DT_SINGLELINE Or DT_VCENTER
   Else
      tR.left = lTextX + lTextWidth
      tR.right = lTextX
      tR.top = lTextY
      tR.bottom = lTextY + lTextHeight + 4
      lFlags = DT_SINGLELINE ' Or DT_VCENTER
   End If
   SetBkMode hDC, TRANSPARENT
   SetTextColor hDC, color
   DrawText hDC, sCaption, -1, tR, lFlags

End Sub

Public Sub UtilDrawSplitGlyph( _
      ByVal hDC As Long, _
      ByVal lLeft As Long, _
      ByVal lTop As Long, _
      ByVal lWidth As Long, _
      ByVal lHeight As Long, _
      ByVal bEnabled As Boolean, _
      ByVal color As Long, _
      ByVal orientation As ECommandBarOrientation _
   )
Dim lCentreY As Long
Dim lCentreX As Long
   
   lCentreX = lLeft + lWidth \ 2
   lCentreY = lTop + lHeight \ 2

   If (orientation = eLeft) Or (orientation = eRight) Then
      SetPixel hDC, lCentreX + 1, lCentreY - 2, &H0
      SetPixel hDC, lCentreX + 1, lCentreY - 1, &H0
      SetPixel hDC, lCentreX + 1, lCentreY, &H0
      SetPixel hDC, lCentreX + 1, lCentreY + 1, &H0
      SetPixel hDC, lCentreX + 1, lCentreY + 2, &H0
      
      SetPixel hDC, lCentreX, lCentreY - 1, &H0
      SetPixel hDC, lCentreX, lCentreY, &H0
      SetPixel hDC, lCentreX, lCentreY + 1, &H0
      
      SetPixel hDC, lCentreX - 1, lCentreY, &H0
   Else
      SetPixel hDC, lCentreX - 2, lCentreY - 1, &H0
      SetPixel hDC, lCentreX - 1, lCentreY - 1, &H0
      SetPixel hDC, lCentreX, lCentreY - 1, &H0
      SetPixel hDC, lCentreX + 1, lCentreY - 1, &H0
      SetPixel hDC, lCentreX + 2, lCentreY - 1, &H0
      SetPixel hDC, lCentreX - 1, lCentreY, &H0
      SetPixel hDC, lCentreX, lCentreY, &H0
      SetPixel hDC, lCentreX + 1, lCentreY, &H0
      SetPixel hDC, lCentreX, lCentreY + 1, &H0
   End If
End Sub
Public Sub UtilDrawSubMenuGlyph( _
      ByVal hDC As Long, _
      ByVal lLeft As Long, _
      ByVal lTop As Long, _
      ByVal lWidth As Long, _
      ByVal lHeight As Long, _
      ByVal bEnabled As Boolean, _
      ByVal color As Long _
   )
Dim lCentreY As Long
Dim lCentreX As Long
Dim tJ As POINTAPI
Dim hPen As Long
Dim hPenOld As Long
   
   lCentreX = lLeft + lWidth \ 2
   lCentreY = lTop + lHeight \ 2
   
   hPen = CreatePen(PS_SOLID, 1, &H0)
   hPenOld = SelectObject(hDC, hPenOld)
   
   MoveToEx hDC, lCentreX - 2, lCentreY - 3, tJ
   LineTo hDC, lCentreX - 2, lCentreY + 4
   MoveToEx hDC, lCentreX - 1, lCentreY - 2, tJ
   LineTo hDC, lCentreX - 1, lCentreY + 3
   MoveToEx hDC, lCentreX, lCentreY - 1, tJ
   LineTo hDC, lCentreX, lCentreY + 2
   SetPixel hDC, lCentreX + 1, lCentreY, &H0
   
   SelectObject hDC, hPenOld
   DeleteObject hPen
   
End Sub
Public Sub UtilDrawCheckGlyph( _
      ByVal hDC As Long, _
      ByVal lLeft As Long, _
      ByVal lTop As Long, _
      ByVal lWidth As Long, _
      ByVal lHeight As Long, _
      ByVal bEnabled As Boolean, _
      ByVal color As Long _
   )
Dim lCentreY As Long
Dim lCentreX As Long
Dim tJ As POINTAPI
Dim hPen As Long
Dim hPenOld As Long
   
   lCentreX = lLeft + lWidth \ 2
   lCentreY = lTop + lHeight \ 2
   
   hPen = CreatePen(PS_SOLID, 1, &H0)
   hPenOld = SelectObject(hDC, hPenOld)
   
   MoveToEx hDC, lCentreX - 3, lCentreY, tJ
   LineTo hDC, lCentreX - 1, lCentreY + 2
   MoveToEx hDC, lCentreX - 3, lCentreY + 1, tJ
   LineTo hDC, lCentreX - 1, lCentreY + 3
   
   MoveToEx hDC, lCentreX - 1, lCentreY + 3, tJ
   LineTo hDC, lCentreX + 5, lCentreY - 3
   MoveToEx hDC, lCentreX - 1, lCentreY + 2, tJ
   LineTo hDC, lCentreX + 5, lCentreY - 4
   
   SelectObject hDC, hPenOld
   DeleteObject hPen
   
End Sub
Public Sub UtilDrawBackground( _
      ByVal hDC As Long, _
      ByVal colorStart As Long, _
      ByVal colorEnd As Long, _
      ByVal left As Long, _
      ByVal top As Long, _
      ByVal width As Long, _
      ByVal Height As Long, _
      Optional ByVal horizontal As Boolean = False _
   )
   If (colorStart = -1) Or (colorEnd = -1) Then
      ' do nothing
   Else
      Dim tR As RECT
      tR.left = left
      tR.top = top
      tR.right = left + width
      tR.bottom = top + Height
      If (colorStart = colorEnd) Then
         ' solid fill:
         Dim hBr As Long
         hBr = CreateSolidBrush(colorStart)
         FillRect hDC, tR, hBr
         DeleteObject hBr
      Else
         ' gradient fill vertical:
         GradientFillRect hDC, tR, _
            colorStart, colorEnd, _
            IIf(horizontal, GRADIENT_FILL_RECT_H, GRADIENT_FILL_RECT_V)
      End If
   End If
End Sub

Private Sub GradientFillRect( _
      ByVal lhDC As Long, _
      tR As RECT, _
      ByVal oStartColor As OLE_COLOR, _
      ByVal oEndColor As OLE_COLOR, _
      ByVal eDir As GradientFillRectType _
   )
Dim hBrush As Long
Dim lStartColor As Long
Dim lEndColor As Long
Dim lR As Long
   
   ' Use GradientFill:
   If (HasGradientAndTransparency) Then
      lStartColor = TranslateColor(oStartColor)
      lEndColor = TranslateColor(oEndColor)
   
      Dim tTV(0 To 1) As TRIVERTEX
      Dim tGR As GRADIENT_RECT
      
      setTriVertexColor tTV(0), lStartColor
      tTV(0).x = tR.left
      tTV(0).y = tR.top
      setTriVertexColor tTV(1), lEndColor
      tTV(1).x = tR.right
      tTV(1).y = tR.bottom
      
      tGR.UpperLeft = 0
      tGR.LowerRight = 1
      
      GradientFill lhDC, tTV(0), 2, tGR, 1, eDir
      
   Else
      ' Fill with solid brush:
      hBrush = CreateSolidBrush(TranslateColor(oEndColor))
      FillRect lhDC, tR, hBrush
      DeleteObject hBrush
   End If
   
End Sub

Private Sub setTriVertexColor(tTV As TRIVERTEX, lColor As Long)
Dim lRed As Long
Dim lGreen As Long
Dim lBlue As Long
   lRed = (lColor And &HFF&) * &H100&
   lGreen = (lColor And &HFF00&)
   lBlue = (lColor And &HFF0000) \ &H100&
   setTriVertexColorComponent tTV.Red, lRed
   setTriVertexColorComponent tTV.Green, lGreen
   setTriVertexColorComponent tTV.Blue, lBlue
End Sub
Private Sub setTriVertexColorComponent(ByRef iColor As Integer, ByVal
 lComponent As Long)
   If (lComponent And &H8000&) = &H8000& Then
      iColor = (lComponent And &H7F00&)
      iColor = iColor Or &H8000
   Else
      iColor = lComponent
   End If
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

Public Function TranslateColor(ByVal oClr As OLE_COLOR, _
                        Optional hPal As Long = 0) As Long
    ' Convert Automation color to Windows color
    If OleTranslateColor(oClr, hPal, TranslateColor) Then
        TranslateColor = CLR_INVALID
    End If
End Function

Public Property Get BlendColor( _
      ByVal oColorFrom As OLE_COLOR, _
      ByVal oColorTo As OLE_COLOR, _
      Optional ByVal Alpha As Long = 128 _
   ) As Long
Dim lCFrom As Long
Dim lCTo As Long
   lCFrom = TranslateColor(oColorFrom)
   lCTo = TranslateColor(oColorTo)
Dim lSrcR As Long
Dim lSrcG As Long
Dim lSrcB As Long
Dim lDstR As Long
Dim lDstG As Long
Dim lDstB As Long
   lSrcR = lCFrom And &HFF
   lSrcG = (lCFrom And &HFF00&) \ &H100&
   lSrcB = (lCFrom And &HFF0000) \ &H10000
   lDstR = lCTo And &HFF
   lDstG = (lCTo And &HFF00&) \ &H100&
   lDstB = (lCTo And &HFF0000) \ &H10000
     
   
   BlendColor = RGB( _
      ((lSrcR * Alpha) / 255) + ((lDstR * (255 - Alpha)) / 255), _
      ((lSrcG * Alpha) / 255) + ((lDstG * (255 - Alpha)) / 255), _
      ((lSrcB * Alpha) / 255) + ((lDstB * (255 - Alpha)) / 255) _
      )
      
End Property



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 Function IFontOf(ifnt As IFont) As IFont
   Set IFontOf = ifnt
End Function

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