用VBA提取Word文档中内嵌的Excel对象

lydia_liu

因为要做一份Excel汇总报告，内容从多个格式相似的Word文档里内嵌的Excel对象提取。在网上搜了很久，发现直接打开并编辑Excel对象相当困难，于是采取了一个间接的方法，先把内嵌的Excel对象存下来，再另外做汇总。网上关于Word VBA的资料实在很少，尝试了很久才解决了。在此把相关的代码贴出来，希望对后来者提供一点帮助。在高手如云的Excelhome这么做似乎有点不自量力，希望大家多点支持，少点拍砖哦。

说明：1、原始的Word文档放在名为“word”的子目录里
           2、包含本代码的宏文档放在“word”的上一层
           3、提取出来的Excel文档存到名为“excel”的子目录，和“word”并列
           4、因为内嵌的Excel文档比较多，加了一个条件判断，只把label包含有“问题”的Excel存下来，不需要的话可以去掉
           5、运行代码时Excel处于关闭状态，所有word文档（除了本宏文档）处于关闭状态
           6、Word的版本为2003

Sub Export_Embedded_Excel()
Dim wdDoc As Document   '用于打开子目录里word文档
Dim iCtr As Integer     '用于遍历word文档里Inlineshapes
Dim i As Long           '用于遍历文件夹里的word文档
Dim xlApp As Object     '用于打开内嵌object
Dim objName As String   '用于获得内嵌object的label
Dim city As String      '用于获得word文档的文件名并作为Excel文档命名的一部分
path = ThisDocument.path
On Error Resume Next
' 逐个打开word文件夹里的文档
With Application.FileSearch
    .NewSearch
    .LookIn = path & "\word"
    .SearchSubFolders = False
    .FileName = "*.doc"
    .FileType = msoFileTypeWordDocuments
    If .Execute() > 0 Then
        For i = 1 To .FoundFiles.Count
            Set wdDoc = Documents.Open(FileName:=.FoundFiles(i))
            city = Left(ActiveDocument.Name, Len(ActiveDocument.Name) - 4)
            Set xlApp = CreateObject("Excel.Application")        '这行代码很关键
' 把文档里内嵌的、名字里包含“问题”的excel文件保存下来
            For iCtr = 1 To wdDoc.InlineShapes.Count
                If wdDoc.InlineShapes(iCtr).Type = wdInlineShapeEmbeddedOLEObject Then
                    If wdDoc.InlineShapes(iCtr).OLEFormat.ProgID = "Excel.Sheet.8" Then
                        If wdDoc.InlineShapes(iCtr).OLEFormat.IconLabel Like "*问题*" Then
                        objName = wdDoc.InlineShapes(iCtr).OLEFormat.IconLabel
                        wdDoc.InlineShapes(iCtr).OLEFormat.Open
                        Set xlApp = GetObject(, "Excel.Application")
                        xlApp.Workbooks(1).SaveAs FileName:=path & "\excel\" & city & objName & iCtr & ".xls"
                        xlApp.Workbooks(1).Close
                        End If
                    End If
                End If
            Next iCtr
            xlApp.Quit
            Set xlApp = Nothing
            wdDoc.Close False
' 下一个文档
        Next i
    End If
End With
End Sub

Admin

   

很遗憾通知楼上朋友，您的帖子在24小时之内没有任何回复！

通常情况下，本论坛发布的主题帖会在8小时被回复或处理。您的帖子在24小时之内未被回复，其中的原因可能是：

1、问题表述不清、模棱两可，难以理解，帮助者被搞晕了，夺帖而出；
2、没有上传必要的附件，或附件被遗忘在某个角落；
3、发帖提问时，语气带棱角、带挑衅，不幸被列入不受欢迎的帖子；
4、所提问题不成立，或提不合理的要求，乐于助人者使出“走为上”之计；
5、话题较偏、较冷或者发布到了不合适的版块，暂时无人问津，顾影自怜。


为了提高您的问题解决效率，我们推荐您阅读以下文章：
* 如何发表新话题和上传附件：http://club.excelhome.net/thread-45649-1-1.html
* 发帖的技巧：http://club.excelhome.net/thread-176339-1-1.html
* EH技术论坛的最佳学习方法：http://club.excelhome.net/thread-117862-1-1.html

gl_zhangt

多谢分享！！好人一生平安！！

同心自相知

高手能帮我看看这个要怎么写好吗？谢谢！

wdtdzhi

多谢分享，学习中！！！