1 ' Original Code by Terry Kreft
   2 ' Modified by Stephen Lebans
   3 ' Contact Stephen@lebans.com
   4 
   5 
   6 Option Private Module
   7 Option Explicit
   8 
   9 '************  Code Start  ***********
  10 Private Const GMEM_MOVEABLE = &H2
  11 Private Const GMEM_ZEROINIT = &H40
  12 Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
  13 
  14 Private Const LF_FACESIZE = 32
  15 
  16 Private Const FW_BOLD = 700
  17 
  18 Private Const CF_APPLY = &H200&
  19 Private Const CF_ANSIONLY = &H400&
  20 Private Const CF_TTONLY = &H40000
  21 Private Const CF_EFFECTS = &H100&
  22 Private Const CF_ENABLETEMPLATE = &H10&
  23 Private Const CF_ENABLETEMPLATEHANDLE = &H20&
  24 Private Const CF_FIXEDPITCHONLY = &H4000&
  25 Private Const CF_FORCEFONTEXIST = &H10000
  26 Private Const CF_INITTOLOGFONTSTRUCT = &H40&
  27 Private Const CF_LIMITSIZE = &H2000&
  28 Private Const CF_NOFACESEL = &H80000
  29 Private Const CF_NOSCRIPTSEL = &H800000
  30 Private Const CF_NOSTYLESEL = &H100000
  31 Private Const CF_NOSIZESEL = &H200000
  32 Private Const CF_NOSIMULATIONS = &H1000&
  33 Private Const CF_NOVECTORFONTS = &H800&
  34 Private Const CF_NOVERTFONTS = &H1000000
  35 Private Const CF_OEMTEXT = 7
  36 Private Const CF_PRINTERFONTS = &H2
  37 Private Const CF_SCALABLEONLY = &H20000
  38 Private Const CF_SCREENFONTS = &H1
  39 Private Const CF_SCRIPTSONLY = CF_ANSIONLY
  40 Private Const CF_SELECTSCRIPT = &H400000
  41 Private Const CF_SHOWHELP = &H4&
  42 Private Const CF_USESTYLE = &H80&
  43 Private Const CF_WYSIWYG = &H8000
  44 Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
  45 Private Const CF_NOOEMFONTS = CF_NOVECTORFONTS
  46 
  47 Public Const LOGPIXELSY = 90
  48 
  49 Public Type FormFontInfo
  50   name As String
  51   Weight As Integer
  52   Height As Integer
  53   UnderLine As Boolean
  54   Italic As Boolean
  55   Color As Long
  56 End Type
  57 
  58 Private Type LOGFONT
  59   lfHeight As Long
  60   lfWidth As Long
  61   lfEscapement As Long
  62   lfOrientation As Long
  63   lfWeight As Long
  64   lfItalic As Byte
  65   lfUnderline As Byte
  66   lfStrikeOut As Byte
  67   lfCharSet As Byte
  68   lfOutPrecision As Byte
  69   lfClipPrecision As Byte
  70   lfQuality As Byte
  71   lfPitchAndFamily As Byte
  72   lfFaceName(LF_FACESIZE) As Byte
  73 End Type
  74 
  75 Private Type FONTSTRUC
  76   lStructSize As Long
  77   hwnd As Long
  78   hdc As Long
  79   lpLogFont As Long
  80   iPointSize As Long
  81   flags As Long
  82   rgbColors As Long
  83   lCustData As Long
  84   lpfnHook As Long
  85   lpTemplateName As String
  86   hInstance As Long
  87   lpszStyle As String
  88   nFontType As Integer
  89   MISSING_ALIGNMENT As Integer
  90   nSizeMin As Long
  91   nSizeMax As Long
  92 End Type
  93 
  94 Private Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" _
  95 (pChoosefont As FONTSTRUC) As Long
  96 Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
  97 Private Declare Function GlobalAlloc Lib "kernel32" _
  98   (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
  99 Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
 100 (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
 101 Private Declare Function GetDeviceCaps Lib "gdi32" _
 102   (ByVal hdc As Long, ByVal nIndex As Long) As Long
 103 Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
 104 
 105 
 106 Private Function MulDiv(In1 As Long, In2 As Long, In3 As Long) As Long
 107 Dim lngTemp As Long
 108   On Error GoTo MulDiv_err
 109   If In3 <> 0 Then
 110     lngTemp = In1 * In2
 111     lngTemp = lngTemp / In3
 112   Else
 113     lngTemp = -1
 114   End If
 115 MulDiv_end:
 116   MulDiv = lngTemp
 117   Exit Function
 118 MulDiv_err:
 119   lngTemp = -1
 120   Resume MulDiv_err
 121 End Function
 122 Private Function ByteToString(aBytes() As Byte) As String
 123   Dim dwBytePoint As Long, dwByteVal As Long, szOut As String
 124   dwBytePoint = LBound(aBytes)
 125   While dwBytePoint <= UBound(aBytes)
 126     dwByteVal = aBytes(dwBytePoint)
 127     If dwByteVal = 0 Then
 128       ByteToString = szOut
 129       Exit Function
 130     Else
 131       szOut = szOut & Chr$(dwByteVal)
 132     End If
 133     dwBytePoint = dwBytePoint + 1
 134   Wend
 135   ByteToString = szOut
 136 End Function
 137 
 138 Private Sub StringToByte(InString As String, ByteArray() As Byte)
 139 Dim intLbound As Integer
 140   Dim intUbound As Integer
 141   Dim intLen As Integer
 142   Dim intX As Integer
 143   intLbound = LBound(ByteArray)
 144   intUbound = UBound(ByteArray)
 145   intLen = Len(InString)
 146   If intLen > intUbound - intLbound Then intLen = intUbound - intLbound
 147 For intX = 1 To intLen
 148 ByteArray(intX - 1 + intLbound) = Asc(Mid(InString, intX, 1))
 149 Next
 150 End Sub
 151 
 152 
 153 Public Function DialogFont(ByRef f As FormFontInfo, Optional hwnd As Long = 0) As Boolean
 154   Dim LF As LOGFONT, FS As FONTSTRUC
 155   Dim lLogFontAddress As Long, lMemHandle As Long
 156 
 157   LF.lfWeight = f.Weight
 158   LF.lfItalic = f.Italic * -1
 159   LF.lfUnderline = f.UnderLine * -1
 160   LF.lfHeight = -MulDiv(CLng(f.Height), GetDeviceCaps(GetDC(Application.hwnd), LOGPIXELSY), 72)
 161   Call StringToByte(f.name, LF.lfFaceName())
 162   FS.rgbColors = f.Color
 163   FS.lStructSize = Len(FS)
 164 
 165     FS.hwnd = hwnd ' April 2 FOnt Dialog is BEHIND CALENDAR!!! Application.hWndAccessApp
 166 
 167   lMemHandle = GlobalAlloc(GHND, Len(LF))
 168   If lMemHandle = 0 Then
 169     DialogFont = False
 170     Exit Function
 171   End If
 172 
 173   lLogFontAddress = GlobalLock(lMemHandle)
 174   If lLogFontAddress = 0 Then
 175     DialogFont = False
 176     Exit Function
 177   End If
 178 
 179   CopyMemory ByVal lLogFontAddress, LF, Len(LF)
 180   FS.lpLogFont = lLogFontAddress
 181   FS.flags = CF_SCREENFONTS Or CF_EFFECTS Or CF_INITTOLOGFONTSTRUCT
 182   If ChooseFont(FS) = 1 Then
 183     CopyMemory LF, ByVal lLogFontAddress, Len(LF)
 184     f.Weight = LF.lfWeight
 185     f.Italic = CBool(LF.lfItalic)
 186     f.UnderLine = CBool(LF.lfUnderline)
 187     f.name = ByteToString(LF.lfFaceName())
 188     f.Height = CLng(FS.iPointSize / 10)
 189     f.Color = FS.rgbColors
 190     DialogFont = True
 191   Else
 192     DialogFont = False
 193   End If
 194 End Function
 195 
 196 Function test_DialogFont() As String
 197     Dim f As FormFontInfo
 198     With f
 199       .Color = 255
 200       .Height = 60
 201       .Weight = 700
 202       .Italic = False
 203       .UnderLine = True
 204       .name = "Tahoma"
 205     End With
 206     Call DialogFont(f)
 207     With f
 208         'Debug.Print "Font Name: "; .name
 209         'Debug.Print "Font Size: "; .Height
 210         'Debug.Print "Font Weight: "; .Weight
 211         'Debug.Print "Font Italics: "; .Italic
 212         'Debug.Print "Font Underline: "; .UnderLine
 213         'Debug.Print "Font COlor: "; .Color
 214         test_DialogFont = .name
 215 
 216     End With
 217 End Function
 218 '************  Code End  ***********
 219 
 220 
 221 
 222