Wie kann man mit VBA testen, ob eine Schriftart installiert ist?

Question

Wie kann ich am einfachsten mit VBA prüfen, ob eine bestimmte Schriftart installiert ist?

Answer 1

http://www.vbcity.com/forums/topic.asp?tid=57012
leitet weiter zu
http://vbcity.com/forums/t/55257.aspx

Dieser vb6-Code ist mit VBA kompatibel:

Function FontIsInstalled(sFont As String) As Boolean
    '' This reference should already be set by default
    '' Tools > References > OLE Automation
    Dim NewFont As StdFont
    On Error Resume Next
    Set NewFont = New StdFont
    With NewFont
        ' Assign the proposed font name
        ' Will not be assigned if font doesn't exist
        .Name = sFont
        ' Return true if font assignment succeded
        FontIsInstalled = (StrComp(sFont, .Name, vbTextCompare) = 0)
        ' return actual font name through arguments
        sFont = .Name
    End With
End Function

Answer 2

OK, wie es sich gehört, habe ich 30 Sekunden, nachdem ich dies gepostet hatte, eine Lösung gefunden. Und das trotz einer 10-minütigen Suche, bevor ich auf SO.... zurückgriff.

Installierte Schriftarten auflisten

Mit dem folgenden Verfahren wird eine Liste der installierten Schriftarten in Spalte A des aktiven Arbeitsblatts angezeigt. Sie verwendet die FindControl Methode, um das Steuerelement Schriftart in der Symbolleiste Formatierung zu finden. Wenn dieses Steuerelement nicht gefunden wird (d.h. es wurde vom Benutzer entfernt), wird eine temporäre CommandBar erstellt und das Font-Steuerelement wird ihr hinzugefügt.

Sub ShowInstalledFonts()
    Set FontList = Application.CommandBars("Formatting").FindControl(ID:=1728)

    'If Font control is missing, create a temp CommandBar
    If FontList Is Nothing Then
        Set TempBar = Application.CommandBars.Add
        Set FontList = TempBar.Controls.Add(ID:=1728)
    End If

    'Put the fonts into column A
    Range("A:A").ClearContents
    For i = 0 To FontList.ListCount - 1
        Cells(i + 1, 1) = FontList.List(i + 1)
    Next i

    'Delete temp CommandBar if it exists
    On Error Resume Next
    TempBar.Delete
End Sub

Ist eine Schriftart installiert?

Die folgende Funktion verwendet die gleiche Technik wie die Prozedur ShowInstalledFonts. Sie gibt True zurück, wenn eine bestimmte Schriftart installiert ist.

Function FontIsInstalled(sFont) As Boolean
    'Returns True if sFont is installed
    FontIsInstalled = False
    Set FontList = Application.CommandBars("Formatting").FindControl(ID:=1728)

    'If Font control is missing, create a temp CommandBar
    If FontList Is Nothing Then
        Set TempBar = Application.CommandBars.Add
        Set FontList = TempBar.Controls.Add(ID:=1728)
    End If

    For i = 0 To FontList.ListCount - 1
        If FontList.List(i + 1) = sFont Then
            FontIsInstalled = True
            On Error Resume Next
            TempBar.Delete
            Exit Function
        End If
    Next i

    'Delete temp CommandBar if it exists
    On Error Resume Next
    TempBar.Delete
End Function

Die folgende Anweisung zeigt, wie Sie diese Funktion in einer VBA-Prozedur verwenden können. Sie zeigt True in einem Meldungsfeld an, wenn das System des Benutzers die Schriftart Comic Sans MS enthält.

MsgBox FontIsInstalled("Comic Sans MS")

Der obige Text war ursprünglich unter diese URL , abgerufen aus dem Internet-Archiv am 2020-02-05.

Answer 3

Bei der Verwendung von Apis gibt es

EnumFonts Die Funktion EnumFonts listet die auf einem bestimmten Gerät verfügbaren Schriftarten auf. Für jede Schriftart mit dem angegebenen Schriftartnamen ruft die Funktion EnumFonts Informationen über diese Schriftart ab und übergibt sie an die anwendungsdefinierte Callback-Funktion. Diese Callback-Funktion kann die Schriftinformationen wie gewünscht verarbeiten. Die Aufzählung wird fortgesetzt, bis keine Schriftarten mehr vorhanden sind oder die Callback-Funktion den Wert Null zurückgibt.

VB4-32,5,6

Declare Function EnumFonts Lib "gdi32" Alias "EnumFontsA" (ByVal hDC As Long, ByVal lpsz As String, ByVal lpFontEnumProc As Long, ByVal lParam As Long) As Long 

ou

Die Funktion EnumFontFamilies listet die Schriften einer bestimmten Schriftfamilie auf, die auf einem bestimmten Gerät verfügbar sind. Diese Funktion ersetzt die Funktion EnumFonts.

VB4-32,5,6

Declare Function EnumFontFamilies Lib "gdi32" Alias "EnumFontFamiliesA" (ByVal hdc As Long, ByVal lpszFamily As String, ByVal lpEnumFontFamProc As Long, ByVal lParam As Long) As Long 

Beispielprogramm

'In a module
Public Const NTM_REGULAR = &H40&
Public Const NTM_BOLD = &H20&
Public Const NTM_ITALIC = &H1&
Public Const TMPF_FIXED_PITCH = &H1
Public Const TMPF_VECTOR = &H2
Public Const TMPF_DEVICE = &H8
Public Const TMPF_TRUETYPE = &H4
Public Const ELF_VERSION = 0
Public Const ELF_CULTURE_LATIN = 0
Public Const RASTER_FONTTYPE = &H1
Public Const DEVICE_FONTTYPE = &H2
Public Const TRUETYPE_FONTTYPE = &H4
Public Const LF_FACESIZE = 32
Public Const LF_FULLFACESIZE = 64
Type LOGFONT
   lfHeight As Long
   lfWidth As Long
   lfEscapement As Long
   lfOrientation As Long
   lfWeight As Long
   lfItalic As Byte
   lfUnderline As Byte
   lfStrikeOut As Byte
   lfCharSet As Byte
   lfOutPrecision As Byte
   lfClipPrecision As Byte
   lfQuality As Byte
   lfPitchAndFamily As Byte
   lfFaceName(LF_FACESIZE) As Byte
End Type
Type NEWTEXTMETRIC
   tmHeight As Long
   tmAscent As Long
   tmDescent As Long
   tmInternalLeading As Long
   tmExternalLeading As Long
   tmAveCharWidth As Long
   tmMaxCharWidth As Long
   tmWeight As Long
   tmOverhang As Long
   tmDigitizedAspectX As Long
   tmDigitizedAspectY As Long
   tmFirstChar As Byte
   tmLastChar As Byte
   tmDefaultChar As Byte
   tmBreakChar As Byte
   tmItalic As Byte
   tmUnderlined As Byte
   tmStruckOut As Byte
   tmPitchAndFamily As Byte
   tmCharSet As Byte
   ntmFlags As Long
   ntmSizeEM As Long
   ntmCellHeight As Long
   ntmAveWidth As Long
End Type
Declare Function EnumFontFamilies Lib "gdi32" Alias "EnumFontFamiliesA" (ByVal hDC As Long, ByVal lpszFamily As String, ByVal lpEnumFontFamProc As Long, LParam As Any) As Long
Function EnumFontFamProc(lpNLF As LOGFONT, lpNTM As NEWTEXTMETRIC, ByVal FontType As Long, LParam As Long) As Long
   Dim FaceName As String
  'convert the returned string to Unicode
   FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
  'print the form on Form1
   Form1.Print Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
  'continue enumeration
   EnumFontFamProc = 1
End Function

'In a form
Private Sub Form_Load()
   'KPD-Team 2000
   'URL: http://www.allapi.net/
   'E-Mail: KPDTeam@Allapi.net
   Dim hDC As Long
   'set graphics mode to persistent
   Me.AutoRedraw = True
   'enumerates the fonts
   EnumFontFamilies Me.hDC, vbNullString, AddressOf EnumFontFamProc, ByVal 0&
End Sub