VBA User定義｢テーマフォント｣を保存したい

Question

MyPC:Windows10-Excel2016(32bit)
ThemeFontSchemeメソッド/プロパティでアクティブ｢テーマフォント｣を保存する事は下記のマクロで行えました。
やりたい事は、｢フォントをカストマイズ｣して保存(Save)したいのですがコードが分かりません。
何方かご教授よろしくお願いいたします。
Sub Macro1() '参考:テーマフォント保存
    Dim wUserName As String
    Dim wFontPath As String
    wUserName = CreateObject("WScript.Network").UserName
    wFontPath = "C:\Users\" & wUserName & "\AppData\Roaming\Microsoft\Templates\Document Themes\Theme Fonts\"
    ActiveWorkbook.Theme.ThemeFontScheme.Save (wFontPath & "User定義 MS明朝.xml")
End Sub

---

u793nabe

Answer 1

XMLに直接書き出してみる

Option Explicit
'''Microsoft XML v6参照

Private Const uri As String = "http://schemas.openxmlformats.org/drawingml/2006/main"

Public Sub Test()
    Call CreateThemeFont("User定義 ＭＳ明朝", "ＭＳ 明朝", "ＭＳ 明朝", "", "ＭＳ 明朝", "ＭＳ 明朝", "")
End Sub

Public Sub CreateThemeFont _
    (ByVal name As String _
    , ByVal fontname_Major_Latin As String _
    , ByVal fontname_Major_eastAsian As String _
    , ByVal fontname_Major_complexScript As String _
    , ByVal fontname_Minor_Latin As String _
    , ByVal fontname_Minor_eastAsian As String _
    , ByVal fontname_Minor_complexScript As String)

    Dim doc As New MSXML2.DOMDocument60
    Dim dpi As MSXML2.IXMLDOMProcessingInstruction
    dpi = doc.createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8"" standalone=""yes"" ")
    Call doc.appendChild(dpi)
    
    Dim fontScheme As MSXML2.IXMLDOMElement
    Set fontScheme = doc.createNode(NODE_ELEMENT, "fontScheme", uri)
    Call fontScheme.setAttribute("name", name)
    Call doc.appendChild(fontScheme)
    
    Call fontScheme.appendChild(CreateFontXMLNode(doc, "majorFont", fontname_Major_Latin, fontname_Major_eastAsian, fontname_Major_complexScript))
    Call fontScheme.appendChild(CreateFontXMLNode(doc, "minorFont", fontname_Minor_Latin, fontname_Minor_eastAsian, fontname_Minor_complexScript))
    
    Dim path As String
    path = Application.TemplatesPath & "\Document Themes\Theme Fonts\" & name & ".xml"
    
    Call doc.Save(path)
    'Call Application.ActiveWorkbook.Theme.ThemeFontScheme.Load(path)
End Sub

Private Function checkFontName(fontname As String, Optional allowBlank = False) As Boolean
    checkFontName = False
    If allowBlank And fontname = "" Then
        checkFontName = True
    Else
        Dim xlb As Workbook
        Set xlb = ActiveWorkbook
        Dim bar As CommandBar
        Dim c As CommandBarComboBox
        Set bar = Application.CommandBars("Formatting")
    
        Set c = bar.FindControl(ID:=1728)
        Dim index As Integer
        For index = 1 To c.ListCount
            If c.List(index) = fontname Then
                checkFontName = True
                Exit For
            End If
        Next
    End If
End Function

Private Function CreateFontXMLNode(ByRef doc As MSXML2.DOMDocument60 _
    , ByVal fonttag As String _
    , ByVal latin As String _
    , ByVal eastAsian As String _
    , ByVal complexScript As String) As MSXML2.IXMLDOMElement

    Dim fontNode As MSXML2.IXMLDOMElement
    Dim latinNode As MSXML2.IXMLDOMElement
    Dim eaNode As MSXML2.IXMLDOMElement
    Dim csNode As MSXML2.IXMLDOMElement
    
    
    If Not checkFontName(latin) Or Not checkFontName(eastAsian) Or Not checkFontName(complexScript, True) Then
        Err.Raise vbObjectError + 513, , "フォント名が不正です"
    End If
    
    Set fontNode = doc.createNode(NODE_ELEMENT, fonttag, uri)
    Set latinNode = doc.createNode(NODE_ELEMENT, "latin", uri)
    Set eaNode = doc.createNode(NODE_ELEMENT, "ea", uri)
    Set csNode = doc.createNode(NODE_ELEMENT, "cs", uri)
    
    Call latinNode.setAttribute("typeface", latin)
    Call eaNode.setAttribute("typeface", eastAsian)
    Call csNode.setAttribute("typeface", complexScript)
    
    Call fontNode.appendChild(latinNode)
    Call fontNode.appendChild(eaNode)
    Call fontNode.appendChild(csNode)

    Set CreateFontXMLNode = fontNode
End Function

---

個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)

Answer 2

gekkaさん、ご回答ありがとうございます。
早速ご提示いただいたコードを標準モジュールにコピペして試行しようとしたのですが、
次のヶ所で実行Errorが発生…ヘルプ
非力にて解決方法が分かりません…ご教授お願い致します。
    dpi = doc.createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8"" standalone=""yes"" ")
▽ErrorScreen

---

u793nabe

Answer 3

エラーの理由は、Let と Set の間違いですね。

先のコードの
「dpi = doc.createProcessingInstruction(～)」の行を
「Set dpi = doc.createProcessingInstruction(～)」に
書き換えてみてください。

また、保存処理の部分は、
    Dim path As String
    path = Application.TemplatesPath & "\Document Themes\Theme Fonts\" & name & ".xml"
    Call doc.Save(path)
を下記のように書き換えてみました。こちらは存在しないフォルダーの作成処理です。
    Dim path As String
    With CreateObject("Scripting.FileSystemObject")
        path = .BuildPath(Application.TemplatesPath, "Document Themes\Theme Fonts")
        'Call .CreateFolder(path)
        Call CreateObject("WScript.Shell").Run("cmd /c MD """ & path & """", vbHide, True)
        path = .BuildPath(path, name & ".xml")
        Call doc.Save(path)
    End With

Answer 4

gekkaさん、魔界の仮面弁士さん、ご教授ありがとうございました。
私は｢テーマのフォント｣として｢游ゴシック／Ｐ明朝／Ｐゴシック｣を基本的に使わない為、本件を解決したかったのですが、
お陰様でやりたい事が解決しました…感謝

追記：他に｢ＭＳ ゴシック｣も試み成功しました。
 Call CreateThemeFont("User定義 MS明朝", "ＭＳ 明朝", "ＭＳ 明朝", "", "ＭＳ 明朝", "ＭＳ 明朝", "")
 Call CreateThemeFont("User定義 MSゴシック", "ＭＳ ゴシック", "ＭＳ ゴシック", "", "ＭＳ ゴシック", "ＭＳ ゴシック", "")
以上

---

u793nabe