如何提取单词.docx中的所有嵌入式对象多种类型并将其保存到文件夹中？

问题描述

我有一个.docx单词，带有〜50个嵌入式对象。我希望将它们全部保存到具有正确文件名的文件夹中。因为我希望名称正确，所以我不想在线使用.zip方法。嵌入式对象包括PowerPoint，Excel文档，电子邮件，PDF等。

我已经在1-2个在线站点上尝试了VBA解决方案，但是没有一个在工作。似乎效果最好的是该网站上的一个：https://social.msdn.microsoft.com/Forums/exchange/en-US/5920f36f-5338-44ee-881f-5c9777a65e59/copy-embedded-objects-through-vba?forum=exceldev

我正在使用的代码如下所示。运行它时，会弹出一个框，要求我选择一个文件夹。我选择包含（仅）我的.docx文件的文件夹。它在选定的文件夹内创建一个名为“ Embedded”的文件夹，但没有任何内容。有谁知道如何解决它？

Sub ExtractEmbeddedObjects()
' The following macro extracts the embedded objects from all docx & docm files in that folder and outputs them
' to a new 'Embedded' folder in that folder. Each output file's name is prefixed with the parent
' document's name.
'
'Note: The macro only processes docx & docm files - doc files can't be processed this way (though they could be converted to the docx format for processing).
'
Application.ScreenUpdating = False
Dim SBar As Boolean           ' Status Bar flag
Dim StrInFold As String,StrOutFold As String,StrTmpFold As String
Dim StrDocFile As String,StrZipFile As String,Obj_App As Object,i As Long
Dim StrFile As String,StrFileList As String,StrEmbedFile As String,j As Long
StrInFold = GetFolder
If StrInFold = "" Then Exit Sub
' Store current Status Bar status,then switch on
SBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
StrOutFold = StrInFold & "\Embedded"
StrTmpFold = StrInFold & "\Tmp"
'Test for existing tmp & output folders,create they if they don't already exist
If Dir(StrTmpFold,vbDirectory) = "" Then MkDir StrTmpFold
If Dir(StrOutFold,vbDirectory) = "" Then MkDir StrOutFold
'Create a Shell App for accessing the zip archives
Set Obj_App = CreateObject("Shell.Application")
'Look for docx files to process
StrFile = Dir(StrInFold & "\*.doc?",vbNormal)
'Build the file list
While StrFile <> ""
  StrFileList = StrFileList & "|" & StrFile
  StrFile = Dir()
Wend
'process the file list
j = UBound(Split(StrFileList,"|"))
For i = 1 To j
  'ID the document to process
  StrDocFile = StrInFold & "\" & Split(StrFileList,"|")(i)
  ' Report progress on Status Bar.
  Application.StatusBar = "Processing file " & i & " of " & j & ": " & StrDocFile
  'Define the zip name
  StrZipFile = Split(StrDocFile,".")(0) & ".zip"
  'In case the file is in use or zip file has no media
  On Error Resume Next
  'Create the zip file,by simply copying to a new file with a zip extension
  FileCopy StrDocFile,StrZipFile
  'Extract the zip archive's media files to the temporary folder
  Obj_App.NameSpace(StrTmpFold & "\").CopyHere Obj_App.NameSpace(StrZipFile & "\word\embeddings\").Items
  'Delete the zip file - the loop takes care of timing issues
  Do While Dir(StrZipFile) <> ""
    Kill StrZipFile
  Loop
  'Restore error trapping
  On Error GoTo 0
  'Get the temporary folder's file listing
  StrEmbedFile = Dir(StrTmpFold & "\*.*",vbNormal)
  'Process the temporary folder's files
  While StrEmbedFile <> ""
    'Copy the file to the output folder,prefixed with the source file's name
    FileCopy StrTmpFold & "\" & StrEmbedFile,StrOutFold & "\" & Split(Split(StrFileList,"|")(i),".")(0) & StrEmbedFile
    'Delete the media file
    Kill StrTmpFold & "\" & StrEmbedFile
    'Get the next media file
    StrEmbedFile = Dir()
  Wend
Next
'Delete the temporary folder
RmDir StrTmpFold
' Clear the Status Bar
Application.StatusBar = False
' Restore original Status Bar status
Application.DisplayStatusBar = SBar
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0,"Choose a folder",0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

解决方法

我使用的工作应用是：O365。 右键单击嵌入的文件图标（工作表） 》工作表对象 》 转换 》 更改图标 》在“Caption”中，我们可以看到目标文件名。 但是在npp中搜索.docx》.zip解压文件中的所有文件后。 我找不到与上述文件名相关的任何信息。 所以我认为原来的目标文件名还在*.docx中， 但不知道从哪里得到它。