从 PowerPoint VBA 中提取 OLEObject（XML 文档）

Question

我正在用 VBA 开发一个应用程序。用户窗体连接到读取 SPSS Statistics SAV 文件或 SPSS Dimensions MDD 文件的 COM 对象。

此应用程序的一部分将元数据存储在 XML 文档中，以便我们稍后可以检索元数据并重新填充或更新从用户表单创建的图形。只要我们依赖于本地驱动器上存在的 XML 文件，这就可以正常工作——这不是一个理想的解决方案。我们更愿意将 XML 嵌入（而不是链接）到 PPTM 文件中，我已经能够做到这一点（见附件）。

问题是我找不到让 VBA 成功提取 OLEObject XML 文件的方法。

OLEObject 可以从 PPT 中手动打开（鼠标点击/等），并且渲染效果很好。但是，当我们尝试以编程方式提取此文档并将其保存到驱动器以便 VBA 可以将文件路径传递给 COM 对象时，生成的提取 XML 文件总是出现损坏。

我找到的唯一方法是：

metaDoc.Copy
CreateObject("Shell.Application").Namespace(ActivePresentation.Path).self.InvokeVerb "Paste"

我了解到 OLEFormat.ProgID = "Package" 存在一些困难，这可能无法实现所需的行为。

我有一些解决方法，例如创建 PPTM 文件的 ZIP 副本并从该文件夹中提取嵌入的文档 XML 文件，这应该可以工作，但如果有更简单的方法来激活此形状/对象并与之交互它通过 VBA，这将非常有帮助。

这里是一些创建 XML 并插入它的示例代码。问题是怎么解压，还是必须做上面提到的ZIP方式？

Public Const XMLFileName As String = "XML Embedded File.xml"
Sub ExampleCreateEmbedXML()

Dim fso As Object
Dim oFile As Object
Dim metaDoc As Shape
Dim shp As Shape
Dim sld As Slide
Dim user As String
Dim xmlExists As Boolean

xmlExists = False
user = Environ("Username")
XMLFilePath = "C:\Users\" & user & "\" & XMLFileName

Set sld = ActivePresentation.Slides(1)
For Each shp In sld.Shapes
    If shp.Name = XMLFileName Then
    xmlExists = True
    End If
Next

If Not xmlExists Then
'If the XML OLEObject doesn't exist, then create one:

'Create a new file in the active workbook's path
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oFile = fso.CreateTextFile(XMLFilePath)
    oFile.Close

    'And then embed the new xml document into the appropriate slide
    Set metaDoc = sld.Shapes.AddOLEObject(FileName:=XMLFilePath _
            , Link:=False, DisplayAsIcon:=False)
    metaDoc.Name = XMLFileName

'Save this out to a drive so it can be accessed by a COM Object:
    metaDoc.Copy
    CreateObject("Shell.Application").Namespace(ActivePresentation.Path).self.InvokeVerb "Paste"

    'This file will be an empty XML file which will not parse, but even files that have been
    ' created correctly by the COM object (verified against the embed file vs. the extracted file)
    ' do not open properly. It seems that this method of pasting the object yields errors in
    ' xml structure.

    ' I have compared by activating the Metadoc object which renders fine in any XML viewer
    ' but the saved down version does not open and is obviously broken when viewed in txt editor

 Else:
    'The file exists, so at this point the COM object would read it
    ' and do stuff to the document or allow user to manipulate graphics through
    ' userform interfaces which connect to a database

    ' the COM object then saves the XML file

    ' another subroutine will then re-insert the XML File.
    ' this part is not a problem, it's getting VBA to open and read the OLEObject which is
    ' proving to be difficult.

 End If

 End Sub

Answer 1

经过大量（大量）搜索后，我已将其注销并转向几个“B 计划”解决方案之一，但偶然发现了一个可能的解决方案。

我知道DoVerbs 1 激活了嵌入的包文件（.txt、.xml 等），但我无法控制记事本的新实例，我需要从中读取其中包含的 XML。

而不是复制并尝试粘贴对象（手动和编程失败）

    'Save this out to a drive so it can be accessed by a COM Object:
        metaDoc.Copy
    CreateObject("Shell.Application").Namespace(ActivePresentation.Path).self.InvokeVerb "Paste"

我能够使用此处发布的解决方案的略微修改版本：

http://www.excelforum.com/excel-programming-vba-macros/729730-access-another-unsaved-excel-instance-and-unsaved-notepad-text.html

以字符串的形式读取打开的、未保存的记事本实例，然后将其写入新文件。这是从上述链接中记录的NotepadFunctions.ReadNotepad() 函数调用的。

Sub ExtractLocalXMLFile(xlsFile As Object)
    'Extracts an embedded package object (TXT file, for example)
    ' reads string contents in from Notepad instance and
    ' prints a new file with string contents from embed file.
    
    Dim embedSlide As slide
    Dim DataObj As New MSForms.DataObject 'This is the container for clipboard contents/object
    Dim fullXMLString As String         'This is the captured string from clipboard.
    Dim t As Long                       'Timer variable
    
    MsgBox "Navigating to the hidden slide because objects can only be activated when " & _
            "the slide is active."
    
    Set embedSlide = ActivePresentation.Slides("Hidden")
    
    ActivePresentation.Windows(1).View.GotoSlide embedSlide.SlideIndex

    'Make sure no other copies of this exist in temp dir:
    
    On Error Resume Next
        Kill UserName & "\AppData\Local\Temp\" & _
             MetaDataXML_FilePath
                'replace an xls extension with txt
    On Error GoTo 0
    
    xlsFile.OLEFormat.DoVerb 1
            '1 opens XML package object -- ' for xls/xlsm files use Verb 2 to Open.
            ' in which case I can maybe control Notepad.exe
                                
    t = Timer + 1
    
    Do While Timer < t
        'Wait... while the file is opening
    Wend
    
    'Retrieve the contents of the embedded file
    
    fullXMLString = Notepad_Functions.ReadNotepad(Notepad_Functions.FindNotepad("Chart Meta XML"))
    
    'This function closes Notepad (would make it a subroutine, instead.
    
    'CloseAPP_B "NOTEPAD.EXE"  '<--- this function is NOT documented in my example on StackOverflow
    
    'Create a new text file
    
    WriteOutTextFile fullXMLString, MetaDataXML_FilePath
    
    'Get rid of the embedded file
    
    xlsFile.Delete
 
End Sub

Sub WriteOutTextFile(fileString As String, filePath As String)
    
    'Creates a txt file at filePath
    'inserting contents (filestring) from the temp package/XML object
    
    Dim oFile As Object
    Dim fso As Object

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oFile = fso.CreateTextFile(filePath)

    oFile.WriteLine (fileString)
    oFile.Close
    
End Sub