I am developing an application in VBA. Userforms connect to a COM object that reads an SPSS Statistics SAV file or an SPSS Dimensions MDD file.
Part of this application stores metadata in an XML document so that we can retrieve the metadata later and repopulate or update the graphics created from the userforms. This works fine as long as we rely on an XML file existing on a local drive - which is not a desirable solution. We would prefer to embed (not link) the XML in to the PPTM file, which I have been able to do (see attached).
The problem is that I can't find a way to get VBA to extract the OLEObject XML File successfully.
The OLEObject can be opened from PPT manually (mouseclick/etc) and it renders fine. But when we try to programmatically extract this document and save it to a drive so that VBA can pass the file path to the COM object, the resulting extracted XML file always appears corrupted.
The only method I have found is:
metaDoc.Copy
CreateObject("Shell.Application").Namespace(ActivePresentation.Path).self.InvokeVerb "Paste"
I have read that there is some difficulty with OLEFormat.ProgID = "Package" which may not allow for the desired behavior.
I have some workarounds in mind, like creating a ZIP copy of the PPTM file and extracting the embedded document XML file from that folder, which should work, but if there is an easier way to Activate this shape/object and interact with it via VBA, that would be extremely helpful.
Here is some example code that creates the XML and inserts it. The question is how do I extract it, or must I do the ZIP method mentioned above?
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
After a lot (a LOT) of searching, I had written this off and was moving on to one of several "Plan B" solutions, when I stumbled on a possible solution.
I know that DoVerbs 1 activates the embedded package file (.txt, .xml, etc) but I did not have any control over the new instance of Notepad, from which I need to read the XML contained therein.
Instead of copying and trying to paste the object (which fails manually and programmatically)
'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"
I was able to use a slightly modified version of the solution posted here:
to read the open, unsaved instance of Notepad as a string, which I then write to a new file. This is called from the NotepadFunctions.ReadNotepad() function documented in the above mentioned link.
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
来源：https://stackoverflow.com/questions/14745056/extracting-an-oleobject-xml-document-from-powerpoint-vba