Option Explicit
Private Const DEFAULT_PITCH As Long = 0
Private Const FF_DONTCARE As Long = 0
Private Const CLIP_DEFAULT_PRECIS As Long = 0
Private Const OUT_DEFAULT_PRECIS As Long = 0
Private Const DEFAULT_QUALITY As Long = 0
Private Const FW_BOLD As Long = 700
Private Const FW_NORMAL As Long = 400
Private Const LOGPIXELSY As Long = 90
Private Const LF_FACESIZE As Long = 32
Private Const CF_EFFECTS As Long = &H100&
Private Const CF_INITTOLOGFONTSTRUCT As Long = &H40&
Private Const CF_NOVECTORFONTS As Long = &H800&
Private Const CF_SCREENFONTS As Long = &H1
Private Const SWP_NOSIZE As Long = &H1
Private Const SWP_NOZORDER As Long = &H4
Private Const SWP_NOACTIVATE As Long = &H10
Private Const HCBT_ACTIVATE As Long = 5
Private Const WH_CBT As Long = 5
Private Type RECT
left As Long
top As Long
Right As Long
Bottom As Long
End Type
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(1 To LF_FACESIZE) As Byte
End Type
Private Type ChooseFont
lStructSize As Long
hWndOwner As Long
hDC As Long
lpLogFont As Long
iPointSize As Long
flags As Long
rgbColors As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
hInstance As Long
lpszStyle As String
nFontType As Integer
forAlignment As Integer
nSizeMin As Long
nSizeMax As Long
End Type
Private Declare Function ChooseFontA Lib "comdlg32.dll" (ByRef pChoosefont As ChooseFont) As Long
Private Declare Function GetActiveWindow Lib "user32.dll" () As Long
Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function GetCurrentThreadId Lib "KERNEL32" () As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private hHook As Long
Public Function ShowFont(Optional ByRef Font As Variant, Optional ByRef Color As Variant, Optional ByVal CenterScreen As Boolean = True) As StdFont
Dim Result As Long
Dim SelectedFont As LOGFONT
Dim Info As ChooseFont
With Info
.lStructSize = Len(Info)
.hWndOwner = Form1.hWnd
.hDC = 0
.lpLogFont = VarPtr(SelectedFont.lfHeight)
.iPointSize = 0
.flags = CF_NOVECTORFONTS Or CF_SCREENFONTS
If IsMissing(Color) = False Then
.flags = .flags Or CF_EFFECTS
.rgbColors = Color
End If
.lCustData = 0
.lpfnHook = 0
.lpTemplateName = vbNullString
.hInstance = 0
.lpszStyle = vbNullString
.nFontType = 0
.nSizeMin = 0
.nSizeMax = 0
If IsMissing(Font) = False Then
If TypeName(Font) = "String" Then
.flags = .flags Or CF_INITTOLOGFONTSTRUCT
SelectedFont = StdFontToLOGFont(Font)
ElseIf Not Font Is Nothing Then
.flags = .flags Or CF_INITTOLOGFONTSTRUCT
SelectedFont = StdFontToLOGFont(Font)
End If
End If
End With
If CenterScreen Then
If hHook <> 0 Then UnhookWindowsHookEx hHook
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProcHook, App.hInstance, GetCurrentThreadId)
End If
Result = ChooseFontA(Info)
If Result <> 0 Then
Set ShowFont = LOGFontToStdFont(SelectedFont)
If IsMissing(Color) = False Then
Color = Info.rgbColors
End If
Else
Set ShowFont = Nothing
End If
End Function
Private Function StdFontToLOGFont(ByRef Font As Variant) As LOGFONT
Dim FontName() As Byte
Dim Pos As Long
Dim hWnd As Long
Dim hDC As Long
Dim Value As StdFont
If TypeName(Font) = "String" Then
Set Value = New StdFont
Value.Name = Font
Else
Set Value = Font
End If
hWnd = GetDesktopWindow
hDC = GetDC(hWnd)
With StdFontToLOGFont
.lfHeight = -MulDiv(Value.Size, GetDeviceCaps(hDC, LOGPIXELSY), 72)
.lfWidth = 0
.lfEscapement = 0
.lfOrientation = 0
.lfWeight = IIf(Value.Bold, FW_BOLD, FW_NORMAL)
.lfItalic = IIf(Value.Italic, 255, 0)
.lfUnderline = IIf(Value.Underline, 255, 0)
.lfStrikeOut = IIf(Value.Strikethrough, 255, 0)
.lfCharSet = (Value.Charset And 255&)
.lfOutPrecision = OUT_DEFAULT_PRECIS
.lfClipPrecision = CLIP_DEFAULT_PRECIS
.lfQuality = DEFAULT_QUALITY
.lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE
FontName = StrConv(Value.Name, vbFromUnicode)
For Pos = 0 To UBound(FontName)
.lfFaceName(Pos + 1) = FontName(Pos)
Next
End With
ReleaseDC hWnd, hDC
End Function
Private Function LOGFontToStdFont(ByRef Value As LOGFONT) As StdFont
Dim Font As New StdFont
Dim FontName As String
Dim Pos As Long
Dim hWnd As Long
Dim hDC As Long
hWnd = GetDesktopWindow
hDC = GetDC(hWnd)
FontName = StrConv(Value.lfFaceName, vbUnicode)
Pos = InStr(FontName, vbNullChar)
If Pos > 0 Then FontName = left(FontName, Pos - 1)
With Font
.Name = FontName
.Charset = Value.lfCharSet
If Value.lfHeight <> 0 Then
.Size = MulDiv(Abs(Value.lfHeight), 72, GetDeviceCaps(hDC, LOGPIXELSY))
End If
.Weight = Value.lfWeight
.Bold = CBool(Value.lfWeight >= FW_BOLD)
.Italic = CBool(Value.lfItalic <> 0)
.Underline = CBool(Value.lfUnderline <> 0)
.Strikethrough = CBool(Value.lfStrikeOut <> 0)
End With
ReleaseDC hWnd, hDC
Set LOGFontToStdFont = Font
End Function
Private Function WinProcHook(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim WinRect As RECT
Dim PosX As Long, PosY As Long
Dim Width As Long
Dim Height As Long
If lMsg = HCBT_ACTIVATE Then
GetWindowRect wParam, WinRect
With WinRect
Width = .Right - .left
Height = .Bottom - .top
End With
PosX = (Screen.Width / Screen.TwipsPerPixelX - Width) / 2
PosY = (Screen.Height / Screen.TwipsPerPixelY - Height) / 2
SetWindowPos wParam, 0, PosX, PosY, 0, 0, SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE
If hHook <> 0 Then
UnhookWindowsHookEx hHook
hHook = 0
End If
End If
WinProcHook = 0
End Function
