Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
"embedding" fonts in Excel
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
"embedding" fonts in Excel
Did you find the answer.
I am struggling with a similar problem. Mystif skrev: 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
"Cannot use object linking and embedding" - a solution! | Excel Discussion (Misc queries) | |||
Excel - Golf - how to display "-2" as "2 Under" or "4"as "+4" or "4 Over" in a calculation cell | Excel Discussion (Misc queries) | |||
embedding "ISERROR" function into an "IF" statement | Excel Worksheet Functions | |||
What does "No more new fonts may be applied" mean in Excel? | Excel Worksheet Functions | |||
=IF(D13="PAID","YES","NO") Can I change fonts colour | Excel Discussion (Misc queries) |