-1

我正在用 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
4

1 回答 1

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
于 2013-02-11T16:24:51.957 回答