Install font from VBA

[cmdrico7812]

Hello all,

I am designing a database in MS Access and I want the AutoExec macro to install a font when the db opens. I work on a network and I would just install the font to the users PC but everytime the computer is restarted or the user logs off, the WINNT folder is reset to its default settings, therefore deleting any fonts I would add to it. I have the font placed on our network where it won't get lost or deleted. Below is the code I have in my module but I can't get it to work. When I run it, there are no errors, but the font doesn't show up in the c:\WINNT\FONTS folder but when I run a Windows search on my system, the font shows up as being in that folder. Not sure why:
-----START CODE-----
Option Compare Database
Declare Function WriteProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String) As Integer

Declare Function CreateScalableFontResource% Lib "GDI" (ByVal fHidden%, ByVal lpszResourceFile$, ByVal lpszFontFile$, ByVal lpszCurrentPath$)

Declare Function AddFontResource Lib "GDI" (ByVal lpFilename As Any) As Integer

Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
_____________________________________
Public Function CopyRequiredFonts()


On Error GoTo CannotCopy
Dim strFontSource As String, strFontTarget As String, fs As Object

strFontSource = "\\Mainserv\Machining Shared\SPA\FONT\Leadcoat.ttf"
strFontTarget = Environ("SystemRoot") & "\FONTS\"
Set fs = CreateObject("Scripting.FileSystemObject")
fs.copyfile strFontSource, strFontTarget, True
Call Install_TTF("Lead Coat", "Leadcoat.ttf", Environ("SystemRoot") & "\FONTS\")
ExitFunction:
Set fs = Nothing
Exit Function

CannotCopy:

MsgBox "Unable to copy file - received the following error:" & vbCrLf & Err.Number & "; " & Err.Description
Resume ExitFunction

End Function
____________________________________
Sub Install_TTF(FontName$, FontFileName$, WinSysDir$)
Dim Ret%, Res&, FontPath$, FontRes$
Const WM_FONTCHANGE = &H1D
Const HWND_BROADCAST = &HFFFF

FontPath$ = WinSysDir$ + "\" + FontFileName$
FontRes$ = Left$(FontPath$, Len(FontPath$) - 3) + "FOT"

Ret% = CreateScalableFontResource(0, FontRes$, _
FontFileName$, WinSysDir$)
Ret% = AddFontResource(FontRes$)
Res& = SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0)
Ret% = WriteProfileString("fonts", FontName + " " & _
"(TrueType)", FontRes$)
End Sub
-----END CODE-----

Anyone have any ideas on what could be wrong or how I can fix my code? Thanks in advance.

Rico