Question

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

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

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

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

我找到的唯一方法是：

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

我已经读过OLEFormat.ProgID =“Package”存在一些问题，可能无法实现所需的行为。

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

以下是一些创建XML并插入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

经过大量（很多）的搜索后，当我偶然找到一个可能的解决方案时，我已经把它写下来并继续使用其中一个“Plan 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

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

1 个答案: