Attribute VB_Name = "hlp_GetGlobalDialogUnits"
Option Explicit
Option Base 0

'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 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 H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F 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 Declare Function DeleteDC 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 GetTextExtentPoint32 Lib "gdi32.dll" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, ByRef lpSize As POINTAPI) As Long
Private Declare Function GetDialogBaseUnits Lib "user32" () As Long
Private Type POINTAPI
  X As Long
  Y As Long
  End Type

Public Function GetGlobalDialogUnits() As Single
  Dim xLong1 As Long
  Dim xLong2 As Long
  Dim xLong3 As Long
  Dim xType1 As POINTAPI
  
  xLong1 = CreateCompatibleDC(0&)
  If xLong1 = 0& Then
    GetGlobalDialogUnits = 1 / 3
    Else
    xLong2 = CreateFont(-MulDiv(8&, GetDeviceCaps(xLong1, 90&), 72&), 0&, 0&, 0&, 400&, 0&, 0&, 0&, 0&, 0&, 0&, 0&, 0&, "MS Sans Serif")
    'Debug.Print xLong2
    If Not xLong2 = 0& Then xLong3 = SelectObject(xLong1, xLong2)
    Call GetTextExtentPoint32(xLong1, "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890", 62&, xType1)
    GetGlobalDialogUnits = CLng(GetDialogBaseUnits And &HFFFF&) / (2 * CLng(xType1.X / 62&))
    If Not xLong2 = 0& Then Call SelectObject(xLong1, xLong3)
    Call DeleteDC(xLong1)
    End If
  End Function

