none
VBA User定義「テーマフォント」を保存したい RRS feed

  • 質問

  • 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

    2020年7月25日 5:00

回答

  • XMLに直接書き出してみる

    Option Explicit
    '''Microsoft XML v6参照
    
    Private Const uri As String = "http://schemas.openxmlformats.org/drawingml/2006/main"
    
    Public Sub Test()
        Call CreateThemeFont("User定義 MS明朝", "MS 明朝", "MS 明朝", "", "MS 明朝", "MS 明朝", "")
    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!)

    • 回答としてマーク u793nabe 2020年7月27日 3:54
    2020年7月26日 6:04
  • エラーの理由は、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

    • 回答としてマーク u793nabe 2020年7月27日 3:48
    2020年7月26日 23:17

すべての返信

  • XMLに直接書き出してみる

    Option Explicit
    '''Microsoft XML v6参照
    
    Private Const uri As String = "http://schemas.openxmlformats.org/drawingml/2006/main"
    
    Public Sub Test()
        Call CreateThemeFont("User定義 MS明朝", "MS 明朝", "MS 明朝", "", "MS 明朝", "MS 明朝", "")
    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!)

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


    u793nabe

    • 回答としてマーク u793nabe 2020年7月27日 3:48
    • 回答としてマークされていない u793nabe 2020年7月27日 3:55
    2020年7月26日 8:36
  • エラーの理由は、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

    • 回答としてマーク u793nabe 2020年7月27日 3:48
    2020年7月26日 23:17
  • gekkaさん、魔界の仮面弁士さん、ご教授ありがとうございました。
    私は「テーマのフォント」として「游ゴシック/P明朝/Pゴシック」を基本的に使わない為、本件を解決したかったのですが、
    お陰様でやりたい事が解決しました…感謝

    追記:他に「MS ゴシック」も試み成功しました。
     Call CreateThemeFont("User定義 MS明朝", "MS 明朝", "MS 明朝", "", "MS 明朝", "MS 明朝", "")
     Call CreateThemeFont("User定義 MSゴシック", "MS ゴシック", "MS ゴシック", "", "MS ゴシック", "MS ゴシック", "")
    以上

    u793nabe

    2020年7月27日 3:47