If you are working with custom fonts within Excel, you may want to install them automatically on a user’s machine, before they start using your workbook. This can be handled in VBA using the following class:
Create a new class module in your workbook and call it clsFontInstall, and then copy and paste the code below into your new class:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 |
Option Explicit Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long Private Declare Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFileName As String) As Long Private Declare Function SendMessageTimeoutA Lib "user32.dll" ( _ ByVal hWnd As Long, _ ByVal Msg As Long, _ ByVal wParam As Long, _ ByRef lParam As Any, _ ByVal fuFlags As Long, _ ByVal uTimeout As Long, _ ByRef lpdwResult As Long) As Long Private Const WM_FONTCHANGE As Long = &H1D Private Const HWND_BROADCAST As Long = &HFFFF& Private Const SMTO_NORMAL As Long = &H0 Private Const CINT_MATCH As Integer = 0 Private mstrFontName As String Private mstrFontFileName As String Private mlngMilliSeconds As Long Public Property Get FontName() As String FontName = mstrFontName End Property Public Property Let FontName(ByVal Value As String) mstrFontName = Value End Property Public Property Let FontFileName(ByVal Value As String) mstrFontFileName = Value End Property Public Property Let NotifyWindowsTimeOut(ByVal Value As Integer) mlngMilliSeconds = Value End Property Public Function UninstallFonts() As Boolean On Error GoTo ERROR_HANDLER UninstallFonts = False If RemoveFontResource(mstrFontFileName) Then Dim lngReturn As Long Dim lResult As Long lngReturn = SendMessageTimeoutA( _ HWND_BROADCAST, _ WM_FONTCHANGE, _ 0, _ ByVal "windows", _ SMTO_NORMAL, _ 1000, _ lResult) UninstallFonts = True Else UninstallFonts = False End If EXIT_HERE: Exit Function ERROR_HANDLER: UninstallFonts = False GoTo EXIT_HERE End Function Public Function InstallFonts() As Boolean On Error GoTo ERROR_HANDLER Dim lngReturn As Long Dim lngResult As Long InstallFonts = True If IsFontInstalled = False Then If AddFontResource(mstrFontFileName) Then lngReturn = SendMessageTimeoutA( _ HWND_BROADCAST, _ WM_FONTCHANGE, _ 0, _ ByVal "windows", _ SMTO_NORMAL, _ mlngMilliSeconds, _ lngResult) Else InstallFonts = False End If End If EXIT_HERE: Exit Function ERROR_HANDLER: InstallFonts = False GoTo EXIT_HERE End Function Public Function IsFontInstalled() As Boolean On Error GoTo ERR_HANDLER: Dim objFont As New StdFont IsFontInstalled = False objFont.Name = mstrFontName If StrComp(mstrFontName, objFont.Name, vbTextCompare) = CINT_MATCH Then IsFontInstalled = True Else IsFontInstalled = False End If EXIT_HERE: Set objFont = Nothing Exit Function ERR_HANDLER: IsFontInstalled = False GoTo EXIT_HERE End Function Private Sub Class_Initialize() mlngMilliSeconds = 1000 End Sub Private Sub Class_Terminate() On Error Resume Next If IsFontInstalled = True Then Me.UninstallFonts End If End Sub |
To use the class, you can copy and paste the code below into the ThisWorkbook code module, so that the installation happens when the workbook is first opened. Make sure you change the name of the font and location of the font file to whatever font you are working with!
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
Option Explicit Dim oFont As New clsFontInstall Private Sub Workbook_BeforeClose(Cancel As Boolean) ThisWorkbook.Saved = True Set oFont = Nothing End Sub Private Sub Workbook_Open() oFont.FontName = "My Font Name" oFont.FontFileName = ThisWorkbook.Path & "\MyFontFile.ttf" If oFont.InstallFonts = False Then MsgBox "Could not install the font(s): " & oFont.FontName End If End Sub |
Thank you for reading this post. Please take time to read the disclaimer about content found on this site.
Share :
