WordのVBAでフォントの存在チェック

checkFonts

Private Sub checkFonts(doc As Document)
     
    Dim strFonts() As String
    Dim strDocFonts() As String
    
    Dim i, j As Integer
    Dim intFontCnt As Integer
    Dim blnExist As Boolean
    Dim strMsg As String
    Dim fs As New FileSystemObject
    Dim strWorkDir As String
    
    '既存フォント取得
    intFontCnt = 0
    For i = 1 To Application.FontNames.Count
        If Left(Application.FontNames.Item(i), 1) <> "@" Then
            intFontCnt = intFontCnt + 1
        End If
    Next i
    
    ReDim strFonts(intFontCnt - 1)
    For i = 1 To Application.FontNames.Count
        If Left(Application.FontNames.Item(i), 1) <> "@" Then
            strFonts(i - 1) = Application.FontNames.Item(i)
        End If
    Next i
    
    'ドキュメントのフォント取得
    '一時フォルダで作業します
    strWorkDir = fs.GetSpecialFolder(TemporaryFolder) & "\get-fonts-work"
    
    'ワークフォルダ作成(スクラップ＆ビルド)
    If fs.FolderExists(strWorkDir) Then
        fs.DeleteFolder strWorkDir
    End If
    fs.CreateFolder strWorkDir
    
    'サブフォルダ
    fs.CreateFolder strWorkDir & "\extract"
    
    'ファイルをワーク領域にコピー
    fs.CopyFile doc.Path & "\" & doc.Name, strWorkDir & "\temp.zip", True
    
    'ファイルを展開
    unzip strWorkDir & "\temp.zip", strWorkDir & "\extract"
    
    'XMLからフォント取得
    strDocFonts = getDocFonts(strWorkDir & "\extract" & "\word\fontTable.xml")
    
    
    '比較
    For i = 0 To UBound(strDocFonts)
        
        blnExist = False
        
        For j = 0 To UBound(strFonts)
            If strDocFonts(i) = strFonts(j) Then
                blnExist = True
                Exit For
            End If
        Next j
        
        If blnExist = False Then
            strMsg = strMsg & vbCrLf & strDocFonts(i)
        End If
        
    Next i
        
    'ワークフォルダ片付け
    fs.DeleteFolder strWorkDir
     
    Set fs = Nothing

    If strMsg = "" Then
        Debug.print "すべてのフォントが利用できます"
    Else
        strMsg = doc.Name & "内の次のフォントが利用できません" & strMsg
        Debug.print strMsg
    End If
    
End Sub

unzip

Private Function unzip(strSource As String, strTarget As String)
    
    Dim objWSH As Object
    Dim blnWait As Boolean
    Dim intVisibleType As Integer '0:off 1:on
    Dim strCommand As String
    
    blnWait = True
    intVisibleType = 0
    
    strCommand = "Expand-Archive -Path " & strSource & " -DestinationPath " & strTarget & " -Force"
    
    Set objWSH = CreateObject("WScript.Shell")
    
    objWSH.Run "powershell -NoLogo -ExecutionPolicy RemoteSigned -Command " & strCommand, intVisibleType, blnWait

End FunctionEnd Sub

getDocFonts

Private Function getDocFonts(strPath As String) As String()
    
    Dim XMLDocument As New MSXML2.DOMDocument60
    Dim nodeFonts As IXMLDOMNode
    Dim node As IXMLDOMNode
    Dim intCnt As Integer
    Dim strFonts() As String
    
    XMLDocument.async = False
    
    XMLDocument.Load strPath
        
    If (XMLDocument.parseError.ErrorCode <> 0) Then
        'XMLParseエラー
        getDocFonts = strFonts
        Exit Function
        
    End If
    
    Set nodeFonts = XMLDocument.ChildNodes(1)
    
    intCnt = 0
    
    'fontsの子ノードがfont
    For Each node In nodeFonts.ChildNodes
        If node.Attributes(0).NodeValue <> "" Then
            intCnt = intCnt + 1
        End If
    Next node
    
    ReDim strFonts(intCnt - 1)
    intCnt = 0
    For Each node In nodeFonts.ChildNodes
        If node.Attributes(0).NodeValue <> "" Then
            strFonts(intCnt) = node.Attributes(0).NodeValue
            intCnt = intCnt + 1
        End If
    Next node

    Set node = Nothing
    Set nodeFonts = Nothing
        
    getDocFonts = strFonts
    
End Function