M
Mystif
Hey there everyone,
I do not know what I missed, but I must have missed something...
The code (below) runs without errors in Excel 2003 on Vista and XP. It
does copy the font into the font folder, but it is not registering
right.
At the CMD I can DIR the fonts folder and see that the file is there,
but if I look using explorer it is not visible (not font name or file
name).
For this upload I changed the location of font file to "C:\temp\". The
actual location of the file is on a network server and is accessed via
UNC.
When this codes works as intended it would copy the font, register the
font, and notify all open applications, including Excel, about the
font.
As far as I can tell, this is about as close as you can get to
embedding a font in Excel, unless you have 2007, which I do not.
Finally, the real work being done here is, with only a few small
changes, taken from code I found online. I had to change things like
"user" to "user32" and add aliases to make the errors stop. Without
the "32" it could not find the file, and without the alias it would
say it could not find an entry point.
Thank you, in advance.
Mystif
Private colFoundFiles As New Collection
Private strPath As String
Private Declare Function CreateScalableFontResource Lib "gdi32" _
Alias "CreateScalableFontResourceA" (ByVal fHidden As Long, _
ByVal lpszResourceFile As String, ByVal lpszFontFile As String, _
ByVal lpszCurrentPath As String) As Long
Private Declare Function AddFontResource Lib "gdi32" Alias _
"AddFontResourceA" (ByVal lpFileName As String) As Long
Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Function WriteProfileString Lib "Kernel32" Alias _
"WriteProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As String, ByVal lpString As String) As Integer
Private Sub Workbook_Open()
IsFontInstalled
End Sub
Sub IsFontInstalled()
Dim lngFileCount As Long
strPath = Environ("SystemRoot") & "\Fonts"
With Application.FileSearch
.NewSearch
.LookIn = strPath
.Filename = "astronbv.ttf"
.SearchSubFolders = False
.FileType = msoFileTypeAllFiles
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) = 0 Then
FileCopy "C:\Temp\astronbv.ttf", strPath & "\astronbv.ttf"
Install_TTF "Astron Boy Video", "astronbv.ttf", _
Environ("SystemRoot") & "\System32"
Else
Exit Sub
End If
End With
End Sub
' This sub installs a TrueType font and makes it available to
' all Windows apps. It takes these arguments:
'
' FontName$ is the font's name (e.g. "Goudy Old Style")
'
' FontFileName$ is the font's filename (e.g. "GOUDOS.TTF")
'
' WinSysDir$ is the user's System folder (e.g.
' "C:\WINDOWS\SYSTEM" or "C:\WINDOWS\SYSTEM32")
'
' ** Before calling this sub, your code must copy the font file
' to the user's Fonts folder. **
'
Sub Install_TTF(FontName$, FontFileName$, WinSysDir$)
Dim Ret%, Res&, FontPath$, FontRes$
Const WM_FONTCHANGE = &H1D
Const HWND_BROADCAST = &HFFFF
FontPath$ = Environ("SystemRoot") & "\Fonts\" & FontFileName$
FontRes$ = WinSysDir$ & "\" & Left$(FontFileName$, _
Len(FontFileName$) - 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
I do not know what I missed, but I must have missed something...
The code (below) runs without errors in Excel 2003 on Vista and XP. It
does copy the font into the font folder, but it is not registering
right.
At the CMD I can DIR the fonts folder and see that the file is there,
but if I look using explorer it is not visible (not font name or file
name).
For this upload I changed the location of font file to "C:\temp\". The
actual location of the file is on a network server and is accessed via
UNC.
When this codes works as intended it would copy the font, register the
font, and notify all open applications, including Excel, about the
font.
As far as I can tell, this is about as close as you can get to
embedding a font in Excel, unless you have 2007, which I do not.
Finally, the real work being done here is, with only a few small
changes, taken from code I found online. I had to change things like
"user" to "user32" and add aliases to make the errors stop. Without
the "32" it could not find the file, and without the alias it would
say it could not find an entry point.
Thank you, in advance.
Mystif
Private colFoundFiles As New Collection
Private strPath As String
Private Declare Function CreateScalableFontResource Lib "gdi32" _
Alias "CreateScalableFontResourceA" (ByVal fHidden As Long, _
ByVal lpszResourceFile As String, ByVal lpszFontFile As String, _
ByVal lpszCurrentPath As String) As Long
Private Declare Function AddFontResource Lib "gdi32" Alias _
"AddFontResourceA" (ByVal lpFileName As String) As Long
Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Function WriteProfileString Lib "Kernel32" Alias _
"WriteProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As String, ByVal lpString As String) As Integer
Private Sub Workbook_Open()
IsFontInstalled
End Sub
Sub IsFontInstalled()
Dim lngFileCount As Long
strPath = Environ("SystemRoot") & "\Fonts"
With Application.FileSearch
.NewSearch
.LookIn = strPath
.Filename = "astronbv.ttf"
.SearchSubFolders = False
.FileType = msoFileTypeAllFiles
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) = 0 Then
FileCopy "C:\Temp\astronbv.ttf", strPath & "\astronbv.ttf"
Install_TTF "Astron Boy Video", "astronbv.ttf", _
Environ("SystemRoot") & "\System32"
Else
Exit Sub
End If
End With
End Sub
' This sub installs a TrueType font and makes it available to
' all Windows apps. It takes these arguments:
'
' FontName$ is the font's name (e.g. "Goudy Old Style")
'
' FontFileName$ is the font's filename (e.g. "GOUDOS.TTF")
'
' WinSysDir$ is the user's System folder (e.g.
' "C:\WINDOWS\SYSTEM" or "C:\WINDOWS\SYSTEM32")
'
' ** Before calling this sub, your code must copy the font file
' to the user's Fonts folder. **
'
Sub Install_TTF(FontName$, FontFileName$, WinSysDir$)
Dim Ret%, Res&, FontPath$, FontRes$
Const WM_FONTCHANGE = &H1D
Const HWND_BROADCAST = &HFFFF
FontPath$ = Environ("SystemRoot") & "\Fonts\" & FontFileName$
FontRes$ = WinSysDir$ & "\" & Left$(FontFileName$, _
Len(FontFileName$) - 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