VBA for saving customised theme font file as xml for use in different documents

Question

Is it possible to automate this feature using VBA?

Customise Theme Fonts

This is the code I have so far

    Dim objFSO As Object

    Dim objXMLThemeFontFile As Object

    Dim strFilePath As String = Environ("APPDATA") & "\Microsoft\Templates\Document Themes\Theme Fonts\"

    Dim strFileName As String = "BrandFonts.xml"

    Dim strFileFullPath = strFilePath & strFileName

    Dim strXML = "<?xml version='1.0' encoding='UTF-8' standalone='yes'?>
    <a:fontScheme xmlns:a='http//schemas.openxmlformats.org/drawingml/2006/main' name='Brand Fonts'>
    <a:majorFont>
    <a:latin typeface='Source Sans Pro'/>
    <a:ea typeface=''/>
    <a:cs typeface=''/>
    </a:majorFont>
    <a:minorFont>
    <a:latin typeface='Source Sans Pro'/>
    <a:ea typeface=''/>
    <a:cs typeface=''/>
    </a:minorFont >
    </a:fontScheme>
    "
    objFSO = CreateObject("Scripting.FileSystemObject")

    objXMLThemeFontFile = objFSO.CreateTextFile(strFileFullPath)

    objXMLThemeFontFile.Write(CStr(strXML))

    objXMLThemeFontFile.Close()
    
    Dim objPres As Presentation
    
    objPres = Globals.ThisAddIn.Application.ActivePresentation
    
    objPres.SlideMaster.Theme.ThemeFontScheme.Load(strFileFullPath)

What works

The xml ThemeFontScheme xml file is written to the correct folder and appears to be structured correctly

What doesn't work

The FontScheme 'Brand Fonts' won't show in the font scheme selector when loaded

I am getting an error

An exception of type 'System.ArgumentException' occurred in BrandTool.dll but was not handled in user code The file cannot be opened due to problems with the contents.

This error occurs on this last line of code

    objPres.SlideMaster.Theme.ThemeFontScheme.Load(strFileFullPath)

Answer 1

Your code was missing the colon after http, you forgot to use "Set" before your set some variables. The code below shows how to implement double quotes in a string. This is working here:

Sub MakeFontTheme()
    Dim objFSO As Object
    Dim objXMLThemeFontFile As Object
    Dim strFilePath As String
    Dim strFileName As String
    Dim strFileFullPath As String
    Dim strXML As String
    
    strFilePath = Environ("APPDATA") & "\Microsoft\Templates\Document Themes\Theme Fonts\"
    strFileName = "BrandFonts.xml"
    strFileFullPath = strFilePath & strFileName
    strXML = "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?><a:fontScheme xmlns:a=""http://schemas.openxmlformats.org/drawingml/2006/main"" name=""Brand Fonts""><a:majorFont><a:latin typeface=""Source Sans Pro""/><a:ea typeface=""""/><a:cs typeface=""""/></a:majorFont><a:minorFont><a:latin typeface=""Source Sans Pro""/><a:ea typeface=""""/><a:cs typeface=""""/></a:minorFont ></a:fontScheme>"
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objXMLThemeFontFile = objFSO.CreateTextFile(strFileFullPath)
    With objXMLThemeFontFile
        .WriteLine (CStr(strXML))
        .Close
    End With
    Dim objPres As Presentation
    objPres = Globals.ThisAddIn.Application.ActivePresentation
    objPres.SlideMaster.Theme.ThemeFontScheme.Load (strFileFullPath)
End Sub