Font

[S+F Waefler]

Hi,
Is there a way to check whether a font is installed on the system using vba?
thanks

sf.wa...@bluewin.ch

[Laurent Longre]

Bonjour,

S+F Waefler a écrit :

> Is there a way to check whether a font is installed on the system using vba?

The following code defines two functions: GetFontNames returns the names
of all installed fonts (in a variant array), and
IsFontInstalled(FontName) returns True if the specified font is
installed.

For instance, if you want to know if Arial is installed:

MsgBox IsFontInstalled("Arial")

GetFontNames uses the executable code of two small callback functions
written in C++ and stored in the VBA code itself (in the strings Code1
and Code2). Tested only with Excel 97 SR-1/2 and Win95 OSR-2.

HTH,

Laurent

'==================================================

Const Code1 = _
"558BEC8B4D1433D28B450883C01CEB02424080380075F9660351" _
& "02B801000000426689510266FF015DC210"

Const Code2 = _
"558BEC53568B551433C00FBFF08B4D088B5A0403DE408A4C311C" _
& "0FBF720284C9880C3375E566014202B8010000005E5B5DC210"

Type SFont
Count As Integer
Length As Integer
Str As String
End Type

Declare Function GetDC Lib "User32" (ByVal hwnd As Long) As Long

Declare Function EnumFontFamiliesA Lib "Gdi32" _
(ByVal hdc As Long, ByVal lpFaceName As Long, _
ByVal lpFontFunc As String, Fonts As SFont) As Long

Function GetFontNames()

Dim CallBack1 As String, CallBack2 As String
Dim Fonts As SFont
Dim FontNames() As String
Dim I As Integer, J As Integer, K As Integer
HexDec = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, _
0, 0, 0, 0, 0, 0, 0, 10, 11, 12, 13, 14, 15)

For I = 1 To Len(Code1) Step 2
CallBack1 = CallBack1 & Chr(HexDec(Asc(Mid(Code1, I, 1)) _
- 48) * 16 + HexDec(Asc(Mid(Code1, I + 1, 1)) - 48))
Next I
For I = 1 To Len(Code2) Step 2
CallBack2 = CallBack2 & Chr(HexDec(Asc(Mid(Code2, I, 1)) _
- 48) * 16 + HexDec(Asc(Mid(Code2, I + 1, 1)) - 48))
Next I

EnumFontFamiliesA GetDC(0), 0, CallBack1, Fonts
Fonts.Str = Space(Fonts.Length)
Fonts.Length = 0
EnumFontFamiliesA GetDC(0), 0, CallBack2, Fonts

ReDim FontNames(1 To Fonts.Count)
J = 1
For I = 1 To Fonts.Count
K = InStr(J, Fonts.Str, Chr(0))
FontNames(I) = Mid(Fonts.Str, J, K - J)
J = K + 1
Next
GetFontNames = FontNames

End Function

'==================================================

Function IsFontInstalled(FontName As String) As Boolean

IsFontInstalled = IsNumeric(Application.Match(FontName, _
GetFontNames, 0))

End Function

'==================================================

[John Walkenbach]

I just posted at my web site a new Excel developer tip that contains exactly
what you need -- assuming you use Excel 97.

----- Posted by John Walkenbach of JWalk & Associates -----
----- Visit "The Spreadsheet Page" -----
----- http://www.j-walk.com/ss -----

S+F Waefler wrote in message <78famv$2s8$1...@bw107zhb.bluewin.ch>...
>Hi,

>Is there a way to check whether a font is installed on the system using
vba?

>thanks
>
>sf.wa...@bluewin.ch
>
>

[Harald Staff]

S+F Waefler wrote:
>
> Hi,
> Is there a way to check whether a font is installed on the system using vba?
> thanks
>
> sf.wa...@bluewin.ch

Hi SF
Here's another and heavier solution, working from excel 5 and up.

It is really a filemanager printer, starting in the folder entered and
reading/printing all files and file properties in directories and
subdirectories. Code is modified from recursive search code posted by
Mark Sadler in april this year. May be edited to perform whatever (even
deleting) on whatever file or filetype. For your question, run it and
enter C:\windows\fonts ,and it will write a file list from that
directory:
---------
Option Explicit 'on top of module

Dim writerow As Integer

Sub Listdirectories()
Dim DirToSearch As String
On Error GoTo nofile
ActiveSheet.Cells(16000, 1).End(xlUp).Select
ActiveCell.Offset(1, 0).Select
writerow = ActiveCell.Row
DirToSearch = InputBox("Enter path for main folder" & Chr(10) & _
"(like C:\MINE )", "Write file list")
If Len(DirToSearch) > 0 Then
GetFilesInDirectory DirToSearch
LookForDirectories (DirToSearch)
Application.StatusBar = False
Application.DisplayAlerts = False
Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(4 _
), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
Application.DisplayAlerts = True
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("D:D").EntireColumn.NumberFormat = "# ### ##0"
Columns("E:E").EntireColumn.AutoFit
End If
Exit Sub
nofile:
MsgBox "No folder with that name found"
End Sub

Sub LookForDirectories(ByVal DirToSearch As String)
Dim counter As Integer
Dim inte As Integer
Dim Directories() As String
Dim Contents As String
counter = 0
DirToSearch = DirToSearch & "\"
Contents = Dir(DirToSearch, vbDirectory)
Do While Contents <> ""
If Contents <> "." And Contents <> ".." Then
If (GetAttr(DirToSearch & Contents) And vbDirectory) = _
vbDirectory Then
counter% = counter% + 1
ReDim Preserve Directories(counter)
Directories(counter) = DirToSearch & Contents
End If
End If
Contents = Dir()
Loop
If counter = 0 Then Exit Sub
For inte = 1 To counter
If writerow > 15500 Then
Worksheets.Add
writerow = 1
End If
GetFilesInDirectory Directories(inte)
LookForDirectories Directories(inte)
Next inte
End Sub

Sub GetFilesInDirectory(ByVal DirToSearch As String)
Dim NextFile As String
NextFile = Dir(DirToSearch & "\" & "*.*")
Do Until NextFile = ""
Application.StatusBar = writerow & " " & DirToSearch & "\" & NextFile
ActiveSheet.Cells(writerow, 1).Value = DirToSearch & "\"
ActiveSheet.Cells(writerow, 2).Value = NextFile
ActiveSheet.Cells(writerow, 3).Value = Mid(NextFile, InStr(NextFile,
".") + 1)
ActiveSheet.Cells(writerow, 4).Value = FileLen(DirToSearch & "\" &
NextFile)
ActiveSheet.Cells(writerow, 4).NumberFormat = "# ### ##0"
ActiveSheet.Cells(writerow, 5).Value = FileDateTime(DirToSearch & "\" &
NextFile)
writerow = writerow + 1
NextFile = Dir()
Loop
End Sub

Best wishes Harald