|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
以下是代码,导出图片一般在30张左右,超过30张以后,如图片大就会停止,或导出的图片大小全为0,不知道什么原因,也没看出代码有什么问题。
dc.rar
(92.17 KB, 下载次数: 15)
- Sub WORDTQ()
- Dim Excel_Shape As Shape, MyFile, fpath
- Dim i%, m%
- Dim Word, Myword As Object
- On Error Resume Next
- If Dir(ThisWorkbook.Path & "\WORD中批量导出的图片", 16) = "" Then MkDir ThisWorkbook.Path & "\WORD中批量导出的图片"
- Set Fld = CreateObject("shell.application").BrowseForFolder(0, "请选择文件夹", 0)
- If Not Fld Is Nothing Then fpath = Fld.Self.Path & ""
- On Error Resume Next '忽略错误
- MyFile = Dir(fpath & "*.doc*")
- Set Word = CreateObject("word.application")
- Do While MyFile <> ""
- Set Myword = Word.documents.Open(fpath & MyFile)
- Word.Visible = flase
- Application.DisplayAlerts = False
- m = 0
- If Myword.Shapes.Count > 0 Then
- On Error Resume Next
- For i = 1 To Myword.Shapes.Count
- Myword.Shapes(i).Select
- Word.Selection.Copy
- ActiveSheet.Cells(i, 1).Activate
- ActiveSheet.PasteSpecial Format:="图片(增强型图元文件)", Link:=False, DisplayAsIcon:=False
- Set Excel_Shape = ActiveSheet.Shapes(1)
- Excel_Shape.Copy
- With ActiveSheet.ChartObjects.Add(0, 0, Excel_Shape.Width, Excel_Shape.Height).Chart
- .Paste
- Application.CutCopyMode = False
- m = m + 1
- .Export ThisWorkbook.Path & "\WORD中批量导出的图片" & Split(MyFile, ".")(0) & m & "◆" & Excel_Shape.Name & ".png"
- .Parent.Delete
- End With
- Excel_Shape.Delete
- Excel_Shape = Nothing
- Next i
- End If
- If Myword.InlineShapes.Count > 0 Then
- On Error Resume Next
- For i = 1 To Myword.InlineShapes.Count
- Myword.InlineShapes(i).Select
- Word.Selection.Copy
- ActiveSheet.Cells(i, 1).Activate
- ActiveSheet.PasteSpecial Format:="图片(增强型图元文件)", Link:=False, DisplayAsIcon:=False
- Set Excel_Shape = ActiveSheet.Shapes(1)
- Excel_Shape.Copy
- With ActiveSheet.ChartObjects.Add(0, 0, Excel_Shape.Width, Excel_Shape.Height).Chart
- .Paste
- Application.CutCopyMode = False
- m = m + 1
- .Export ThisWorkbook.Path & "\WORD中批量导出的图片" & Split(MyFile, ".")(0) & m & "★" & Excel_Shape.Name & ".png"
- .Parent.Delete
- End With
- Excel_Shape.Delete
- Excel_Shape = Nothing
- Next i
- End If
- Myword.Close
- MyFile = Dir
- Loop
- Set Myword = Nothing
- Word.Quit
- Set Word = Nothing
- ActiveSheet.Buttons.Add(450, 3.75, 166, 40).Select
- Selection.OnAction = "WORDTQ"
- Selection.Characters.Text = "多个WORD中图片批量提取"
- MsgBox "导出完毕"
- [A1].Select
- End Sub
复制代码
|
|