0

PowerPoint に実装された InDesign からある種のプリフライト レポートを取得しようとしています。不足している/インストールされているフォントのリストを取得する方法を知っていますか? または、これを確認する方法：

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：

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 に答える