0

我正在尝试从 InDesign 中获取某种在 PowerPoint 中实现的预检报告。您知道如何获取丢失/已安装字体的列表吗？或者如何检查是否：

ActivePresentation.Fonts(i)

是安装字体吗？

Function getFontList()

 Dim LF As LOGFONT
 Dim hDC As Long

 hDC = GetDC(0)
 EnumFontFamiliesEx hDC, LF, AddressOf EnumFontFamProc, ByVal 0&, 0
 QuickSortStringArray FontArray(), 0, UBound(FontArray)

End Function
Sub Main()

Dim PCtr As Long, FCtr As Long
Dim Found As Boolean, FontsMissing As Boolean
Dim Msg As String
Msg = "The Following Presentation fonts were not found:"
Call getFontList
For PCtr = 0 To ActivePresentation.Fonts.Count - 1
    Found = False
    For FCtr = LBound(FontArray) To UBound(FontArray)
        Found = (ActivePresentation.Fonts(PCtr).Name = FontArray(FCtr))
        If Found Then Exit For
    Next
    If Not Found Then
        FontsMissing = True
        Msg = Msg & vbCrLf & ActivePresentation.Fonts(PCtr).Name
    End If
Next
If FontsMissing Then
    MsgBox Msg
End If

End Sub
4

1 回答 1

1

这里有一个使用 Windows API 调用的解决方案。

此 VBA 填充 Access 组合框，但您可以根据需要对其进行调整，因为您需要做的就是获取包含 Windows 中安装的字体的数组或其他结构，并将其与您的ActivePresentation.Fonts(i)

编辑：

鉴于上面链接中的代码（相关部分在此处复制）：

Option Explicit

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

Private Declare Function EnumFontFamiliesEx Lib "gdi32" Alias "EnumFontFamiliesExA" (ByVal hDC As Long, lpLogFont As LOGFONT, ByVal lpEnumFontProc As Long, ByVal LParam As Long, ByVal dw As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long    

'Declare variables required for this module.
Dim FontArray() As String   'The Array that will hold all the Fonts (needed for sorting)
Dim FntInc As Integer       'The FontArray element incremental counter.


Private 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)

   'Dimension the FontArray array variable to hold the next Font Name.
   ReDim Preserve FontArray(FntInc)
   'Place the Font name into the newly dimensioned Array element.
   FontArray(FntInc) = Left$(FaceName, InStr(FaceName, vbNullChar) - 1)

  'continue enumeration
   EnumFontFamProc = 1

   'Increment the Array Element Counter.
   FntInc = UBound(FontArray) + 1
End Function

Public Sub QuickSortStringArray(avarIn() As String, ByVal intLowBound As Integer, _
                                ByVal intHighBound As Integer)
  'GENERAL SUB-PROCEDURE
  '=====================

  'Quicksorts the passed array of Strings
  'avarIn() - array of Strings that gets sorted
  'intLowBound - low bound of array
  'intHighBound - high bound of array

  'Declare Variables...
  Dim intX As Integer, intY As Integer
  Dim varMidBound As Variant, varTmp As Variant

  'Trap Errors
  On Error GoTo PROC_ERR

  'If there is data to sort
  If intHighBound > intLowBound Then
    'Calculate the value of the middle array element
    varMidBound = avarIn((intLowBound + intHighBound) \ 2)
    intX = intLowBound
    intY = intHighBound

    'Split the array into halves
    Do While intX <= intY
      If avarIn(intX) >= varMidBound And avarIn(intY) <= varMidBound Then
        varTmp = avarIn(intX)
        avarIn(intX) = avarIn(intY)
        avarIn(intY) = varTmp
        intX = intX + 1
        intY = intY - 1
      Else
        If avarIn(intX) < varMidBound Then
          intX = intX + 1
        End If
        If avarIn(intY) > varMidBound Then
          intY = intY - 1
        End If
      End If
    Loop

    'Sort the lower half of the array
    QuickSortStringArray avarIn(), intLowBound, intY

    'Sort the upper half of the array
    QuickSortStringArray avarIn(), intX, intHighBound
  End If

PROC_EXIT:
  'Outta here
  Exit Sub

PROC_ERR:
  'Display the Error Trapped
  MsgBox "Error: " & Err.Number & ". " & Err.description, , _
    "QuickSortStringArray"
  'Jump to...
  Resume PROC_EXIT
End Sub

以下代码将填充 - 并排序 - FontArray() 变量：

Dim LF As LOGFONT
Dim hDC As Long
hDC = GetDC(0)
EnumFontFamiliesEx hDC, LF, AddressOf EnumFontFamProc, ByVal 0&, 0
QuickSortStringArray FontArray(), 0, UBound(FontArray)

如果不需要排序数组，只需删除上面代码的最后一行即可。

要获取包含ActivePresentation.Fonts未安装列表的消息框：

Dim PCtr as Long, FCtr as Long
Dim Found as Boolean, FontsMissing as Boolean
Dim Msg as String
Msg = "The Following Presentation fonts were not found:"
For PCtr = 0 to ActivePresentation.Fonts.Count - 1
    Found = False
    For FCtr = LBound(FontArray) to UBound(FontArray)
        Found = (ActivePresentation.Fonts(PCtr).Name = FontArray(FCtr))
        If Found Then Exit For
    Next
    If Not Found Then
        FontsMissing = True
        Msg = Msg  & vbCrLf & ActivePresentation.Fonts(PCtr).Name 
    End If
Next
If FontsMissing Then
    MsgBox Msg
End If

我还没有测试过最后的代码，所以如果它不起作用，请发表带有错误的评论，我将对其进行编辑。

编辑2：

结合两个代码部分：

Dim PCtr as Long, FCtr as Long
Dim Found as Boolean, FontsMissing as Boolean
Dim Msg as String
Dim LF As LOGFONT
Dim hDC As Long
hDC = GetDC(0)
EnumFontFamiliesEx hDC, LF, AddressOf EnumFontFamProc, ByVal 0&, 0
QuickSortStringArray FontArray(), 0, UBound(FontArray)
Msg = "The Following Presentation fonts were not found:"
For PCtr = 0 to ActivePresentation.Fonts.Count - 1
    Found = False
    For FCtr = LBound(FontArray) to UBound(FontArray)
        Found = (ActivePresentation.Fonts(PCtr).Name = FontArray(FCtr))
        If Found Then Exit For
    Next
    If Not Found Then
        FontsMissing = True
        Msg = Msg  & vbCrLf & ActivePresentation.Fonts(PCtr).Name 
    End If
Next
If FontsMissing Then
    MsgBox Msg
End If
于 2013-10-22T23:06:51.967 回答