從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 =「包」，這可能不允許所需的行爲。

我想到了一些解決方法，比如創建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