Excel VBA の新しいフォントパターンの作成

Question

実現したいこと

Excel VBAからパワーポイントファイルの日本語文字用のフォントを変更したい

発生している問題・分からないこと

Excel VBAからパワポファイルを新規作成し、
スライドマスターの新しいテーマのフォントを変更したい。

しかし、以下のコードを実行したところ、
英数字用のフォントは指定のフォントに変更されますが、
日本語文字用のフォントが指定のフォントに変更されません。

ExcelとPowerPointはOffice 365を使用しています。

英数字と日本語共に変更できるようにしたいのですが、
どなたか解決方法をご存知の方がいらっしゃいましたらご教示のほどお願いいたします。

該当のソースコード

Option Explicit

Sub パワポファイル作成()

Dim ppApp as PowerPoint.Application
Dim ppPresentation as PowerPoint.Presentation

Set ppApp = CreateObject("PowerPoint.Application")
Set ppPresentation = ppApp.Presentation.Add

ppPresentaion.SlideMaster.Theme.ThemeFontScheme.MajorFont(msoThemeLatin) = "Meiryo UI"
ppPresentaion.SlideMaster.Theme.ThemeFontScheme.MinorFont(msoThemeLatin) = "Meiryo UI"
ppPresentaion.SlideMaster.Theme.ThemeFontScheme.MajorFont(msoThemeEastAsian) = "Meiryo UI"
ppPresentaion.SlideMaster.Theme.ThemeFontScheme.MinorFont(msoThemeEastAsian) = "Meiryo UI"

End Sub

試したこと・調べたこと

• teratailやGoogle等で検索した
• ソースコードを自分なりに変更した
• 知人に聞いた
• その他

上記の詳細・結果

自分なりにコードについて調べてみましたが、うまく動作させる方法は分かっていません。

補足

特になし

Comments

[meg_]

> 日本語文字用のフォントが指定のフォントに変更されません。
コードは実行可能だがその実行結果はコード実行前と変わっていない、という事でしょうか？

[yu1447]

meg_さん

コードはエラーなどなく実行できており、
英数字のフォントは変わるのですが、日本語のフォントは変わらない状態です。

Answer 1

Excel VBAからパワポファイルを新規作成し、
スライドマスターの新しいテーマのフォントを変更

英数字と日本語共に変更できるようにしたい

Sub CreateNewPresentation()
    
    Dim pptApp As Object    'PowerPoint.Application
    
    On Error Resume Next
    '起動中の PowerPoint アプリケーションのインスタンスを参照
    Set pptApp = GetObject(, "PowerPoint.Application")
    '起動しているインスタンスが見つからない場合
    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo 0
        'PowerPoint アプリケーションの新規インスタンスを生成して参照
        Set pptApp = CreateObject("PowerPoint.Application")
        Application.Visible = True
    End If
    On Error GoTo 0
    
    Dim pptPresentation As Object   'PowerPoint.Presentation
    
    'PowerPoint プレゼンテーションを新規作成
    Set pptPresentation = pptApp.Presentations.Add
    
    'プレゼンテーションの既定の言語を日本語に設定
    pptPresentation.DefaultLanguageID = msoLanguageIDJapanese
    
    Dim strThemeXmlFilePath As String
    
    '独自のテーマフォント設定を定義した XML ファイルを生成する処理を実行し、生成されたファイルの絶対パスを取得する
    strThemeXmlFilePath = CreateThemeFontSchema(FontSchemaName:="ユーザー定義のテーマフォント1", _
                                                MajorFontNameLatin:="Meiryo UI", _
                                                MinorFontNameLatin:="Meiryo UI", _
                                                MajorFontNameEA:="Meiryo UI", _
                                                MinorFontNameEA:="Meiryo UI")
        
    'XML ファイルの生成に成功した場合
    If strThemeXmlFilePath <> "" Then
        'XML ファイルを読み込み、スライドマスターのテーマフォント設定に適用する
        pptPresentation.SlideMaster.Theme.ThemeFontScheme.Load strThemeXmlFilePath
    End If
    
    'スライドマスター表示（サムネイル付き）モードに切り替える
    pptApp.ActiveWindow.ViewType = 12   'ppViewMasterThumbnails
    
    Set pptPresentation = Nothing
    Set pptApp = Nothing

End Sub

'独自のテーマフォント設定を定義した XML ファイルを生成するユーザー定義関数
Private Function CreateThemeFontSchema(ByVal FontSchemaName As String, _
                                       ByVal MajorFontNameLatin As String, _
                                       ByVal MinorFontNameLatin As String, _
                                       ByVal MajorFontNameEA As String, _
                                       ByVal MinorFontNameEA As String) As String
On Error GoTo Err_CreateThemeFontSchema
 
    Dim strXMLPath As String

    '出力先ファイルパスの生成
    strXMLPath = Environ("AppData") & _
                 "\Microsoft\Templates\Document Themes\Theme Fonts\" & _
                 FontSchemaName & ".xml"

    Dim domDoc As Object            'MSXML2.DOMDocument
    Dim domNodeDeclare As Object    'MSXML2.IXMLDOMProcessingInstruction
    Dim domNodeFontScheme As Object 'MSXML2.IXMLDOMNode
    Dim domNodeMajorFont As Object  'MSXML2.IXMLDOMNode
    Dim domNodeMinorFont As Object  'MSXML2.IXMLDOMNode
    Dim domAttribute As Object      'MSXML2.IXMLDOMAttribute
    Dim domElement As Object        'MSXML2.IXMLDOMElement
    
    'XML ドキュメントの作成
    Set domDoc = CreateObject("MSXML2.DOMDocument")
    
    With domDoc
        
        '宣言部ノードの追加
        Set domNodeDeclare = .createProcessingInstruction("xml", _
                                                          "version=""1.0"" encoding=""UTF-8"" standalone=""yes""")
        .appendChild domNodeDeclare
        
        'フォント定義ノードの追加
        Set domNodeFontScheme = .appendChild(.createElement("a:fontScheme"))
        
            Set domAttribute = .createAttribute("xmlns:a")
            domAttribute.Value = "http://schemas.openxmlformats.org/drawingml/2006/main"
            domNodeFontScheme.Attributes.setNamedItem domAttribute
            
            Set domAttribute = .createAttribute("name")
            domAttribute.Value = FontSchemaName
            domNodeFontScheme.Attributes.setNamedItem domAttribute
        
        '見出しフォントの設定
        Set domNodeMajorFont = domNodeFontScheme.appendChild(.createElement("a:majorFont"))
        
            'ラテン語（英数字）
            Set domElement = domNodeMajorFont.appendChild(.createElement("a:latin"))
            Set domAttribute = .createAttribute("typeface")
            domAttribute.Value = MajorFontNameLatin
            domElement.Attributes.setNamedItem domAttribute
            
            '東アジア言語（日本語）
            Set domElement = domNodeMajorFont.appendChild(.createElement("a:ea"))
            Set domAttribute = .createAttribute("typeface")
            domAttribute.Value = MajorFontNameEA
            domElement.Attributes.setNamedItem domAttribute
            
            '複合スクリプト言語
            Set domElement = domNodeMajorFont.appendChild(.createElement("a:cs"))
            Set domAttribute = .createAttribute("typeface")
            domAttribute.Value = ""
            domElement.Attributes.setNamedItem domAttribute
        
        '本文フォント要素の設定
        Set domNodeMinorFont = domNodeFontScheme.appendChild(.createElement("a:minorFont"))
        
            'ラテン語（英数字）
            Set domElement = domNodeMinorFont.appendChild(.createElement("a:latin"))
            Set domAttribute = .createAttribute("typeface")
            domAttribute.Value = MinorFontNameLatin
            domElement.Attributes.setNamedItem domAttribute
            
            '東アジア言語（日本語）
            Set domElement = domNodeMinorFont.appendChild(.createElement("a:ea"))
            Set domAttribute = .createAttribute("typeface")
            domAttribute.Value = MinorFontNameEA
            domElement.Attributes.setNamedItem domAttribute
            
            '複合スクリプト言語
            Set domElement = domNodeMinorFont.appendChild(.createElement("a:cs"))
            Set domAttribute = .createAttribute("typeface")
            domAttribute.Value = ""
            domElement.Attributes.setNamedItem domAttribute
        
        'XML ファイルとして保存
        .Save strXMLPath
        
    End With
    
    'XML ファイルの絶対パスを戻り値として返す
    CreateThemeFontSchema = strXMLPath
    
Exit_CreateThemeFontSchema:
    
    Set domAttribute = Nothing
    Set domElement = Nothing
    Set domNodeMinorFont = Nothing
    Set domNodeMajorFont = Nothing
    Set domNodeFontScheme = Nothing
    Set domDoc = Nothing
    
    Exit Function
    
Err_CreateThemeFontSchema:
    
    Dim strErrMsg As String
    
    strErrMsg = Err.Number & ": " & Err.Description
    Debug.Print strErrMsg
    
    MsgBox strErrMsg, vbCritical, "実行時エラー (CreateThemeFontSchema)"
    
    Resume Exit_CreateThemeFontSchema
End Function

Comments

[yu1447]

回答ありがとうございます。
試したところ問題が解決しました！
ベストアンサーに選ばせていただきました。