從 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