批量从WORD中提取图片，遇到奇怪问题

考试加油站

以下是代码，导出图片一般在30张左右，超过30张以后，如图片大就会停止，或导出的图片大小全为0，不知道什么原因，也没看出代码有什么问题。


dc.rar (92.17 KB, 下载次数: 15)

2022-10-9 16:28 上传

点击文件名下载附件

1. Sub WORDTQ()
   
2.     Dim Excel_Shape As Shape, MyFile, fpath
   
3.     Dim i%, m%
   
4.     Dim Word, Myword As Object
   
5.     On Error Resume Next
   
6.     If Dir(ThisWorkbook.Path & "\WORD中批量导出的图片", 16) = "" Then MkDir ThisWorkbook.Path & "\WORD中批量导出的图片"
   
7.     Set Fld = CreateObject("shell.application").BrowseForFolder(0, "请选择文件夹", 0)
   
8.     If Not Fld Is Nothing Then fpath = Fld.Self.Path & ""
   
9.     On Error Resume Next                              '忽略错误
   
10.     MyFile = Dir(fpath & "*.doc*")
    
11.     Set Word = CreateObject("word.application")
    
12.     Do While MyFile <> ""
    
13.         Set Myword = Word.documents.Open(fpath & MyFile)
    
14.         Word.Visible = flase
    
15.         Application.DisplayAlerts = False
    
16.         m = 0
    
17.         If Myword.Shapes.Count > 0 Then
    
18.             On Error Resume Next
    
19.             For i = 1 To Myword.Shapes.Count
    
20.                 Myword.Shapes(i).Select
    
21.                 Word.Selection.Copy
    
22.                 ActiveSheet.Cells(i, 1).Activate
    
23.                 ActiveSheet.PasteSpecial Format:="图片(增强型图元文件)", Link:=False, DisplayAsIcon:=False
    
24.                 Set Excel_Shape = ActiveSheet.Shapes(1)
    
25.                 Excel_Shape.Copy
    
26.                 With ActiveSheet.ChartObjects.Add(0, 0, Excel_Shape.Width, Excel_Shape.Height).Chart
    
27.                     .Paste
    
28.                     Application.CutCopyMode = False
    
29.                     m = m + 1
    
30.                     .Export ThisWorkbook.Path & "\WORD中批量导出的图片" & Split(MyFile, ".")(0) & m & "◆" & Excel_Shape.Name & ".png"
    
31.                     .Parent.Delete
    
32.                 End With
    
33.                 Excel_Shape.Delete
    
34.                 Excel_Shape = Nothing
    
35.             Next i
    
36.         End If
    
37.         If Myword.InlineShapes.Count > 0 Then
    
38.             On Error Resume Next
    
39.             For i = 1 To Myword.InlineShapes.Count
    
40.                 Myword.InlineShapes(i).Select
    
41.                 Word.Selection.Copy
    
42.                 ActiveSheet.Cells(i, 1).Activate
    
43.                 ActiveSheet.PasteSpecial Format:="图片(增强型图元文件)", Link:=False, DisplayAsIcon:=False
    
44.                 Set Excel_Shape = ActiveSheet.Shapes(1)
    
45.                 Excel_Shape.Copy
    
46.                 With ActiveSheet.ChartObjects.Add(0, 0, Excel_Shape.Width, Excel_Shape.Height).Chart
    
47.                     .Paste
    
48.                     Application.CutCopyMode = False
    
49.                     m = m + 1
    
50.                     .Export ThisWorkbook.Path & "\WORD中批量导出的图片" & Split(MyFile, ".")(0) & m & "★" & Excel_Shape.Name & ".png"
    
51.                     .Parent.Delete
    
52.                 End With
    
53.                 Excel_Shape.Delete
    
54.                 Excel_Shape = Nothing
    
55.             Next i
    
56.         End If
    
57.         Myword.Close
    
58.         MyFile = Dir
    
59.     Loop
    
60.     Set Myword = Nothing
    
61.     Word.Quit
    
62.     Set Word = Nothing
    
63.     ActiveSheet.Buttons.Add(450, 3.75, 166, 40).Select
    
64.     Selection.OnAction = "WORDTQ"
    
65.     Selection.Characters.Text = "多个WORD中图片批量提取"
    
66.     MsgBox "导出完毕"
    
67.     [A1].Select
    
68. End Sub
    

复制代码

aman1516

.Parent.Select
在  .Paste 前面加一句代码
并没有出现楼主所说有情况

aman1516

WORD中直接导出不行吗、

1. Sub PicOut()    'Word图片导出
   
2.     Dim i, j, k
   
3.     On Error Resume Next
   
4.     If Dir(ActiveDocument.Path & "\WORD中批量导出的图片", 16) = "" Then MkDir ActiveDocument.Path & "\WORD中批量导出的图片"
   
5.     Set ImageStream = CreateObject("ADODB.Stream")
   
6.     With ImageStream
   
7.         .Type = 1
   
8.         .Open
   
9.         For i = 1 To ActiveDocument.Shapes.Count
   
10.             k = k + 1
    
11.             ActiveDocument.Shapes(i).Select
    
12.             .Write Selection.EnhMetaFileBits
    
13.             .SaveToFile ActiveDocument.Path & "\WORD中批量导出的图片" & k & " .png"
    
14.         Next
    
15.         For j = 1 To ActiveDocument.InlineShapes.Count
    
16.             k = k + 1
    
17.             ActiveDocument.InlineShapes(j).Select
    
18.             .Write Selection.EnhMetaFileBits
    
19.             .SaveToFile ActiveDocument.Path & "\WORD中批量导出的图片" & k & " .png"
    
20.         Next
    
21.         .Close
    
22.     End With
    
23.     Set ImageStream = Nothing
    
24.     MsgBox "ok"
    
25. End Sub

复制代码

aman1516

详见附件，
WORD图片批量导出.rar (82.38 KB, 下载次数: 51)

2022-10-9 20:18 上传

点击文件名下载附件

考试加油站

aman1516 发表于 2022-10-9 20:19
详见附件，

考试加油站

aman1516 发表于 2022-10-9 19:38
.Parent.Select
在  .Paste 前面加一句代码
并没有出现楼主所说有情况

谢谢帮忙。小图片导出为0大小解决，可是如小图片换成大图片，基本在30处就结束，也就是说只能导出30张左右，后面的就导不出来

smiletwo

smiletwo

以前写的批量导出多个word文档中的图片代码，供参考：

1. Sub smiletwo()
   
2.     Dim Excel_Shape As Shape, MyFile, path
   
3.     Dim i%, m%
   
4.     Dim Word, Myword As Object
   
5.     On Error Resume Next
   
6.     path = ThisWorkbook.path & ""
   
7.     MyFile = Dir(path & "*.doc*")
   
8.     Set Word = CreateObject("word.application")
   
9.     Do While MyFile <> ""
   
10.         Set Myword = Word.documents.Open(path & MyFile)
    
11.         Word.Visible = flase
    
12.         Application.DisplayAlerts = False
    
13.         m = 0
    
14.         If Myword.Shapes.Count > 0 Then
    
15.             For i = 1 To Myword.Shapes.Count
    
16.                Myword.Shapes(i).Select
    
17.                Word.Selection.Copy
    
18.                ActiveSheet.Cells(i, 1).Activate
    
19.                ActiveSheet.PasteSpecial Format:="图片(增强型图元文件)", Link:=False, DisplayAsIcon:=False
    
20.                Set Excel_Shape = ActiveSheet.Shapes(1)
    
21.                Excel_Shape.Copy
    
22.                With ActiveSheet.ChartObjects.Add(0, 0, Excel_Shape.Width, Excel_Shape.Height).Chart
    
23.                   .Paste
    
24.                   m = m + 1
    
25.                   .Export path & "pic" & Split(MyFile, ".")(0) & m & ".jpg"
    
26.                   .Parent.Delete
    
27.                End With
    
28.                Excel_Shape.Delete
    
29.             Next i
    
30.         End If
    
31.         If Myword.InlineShapes.Count > 0 Then
    
32.             For i = 1 To Myword.InlineShapes.Count
    
33.                Myword.InlineShapes(i).Select
    
34.                Word.Selection.Copy
    
35.                ActiveSheet.Cells(i, 1).Activate
    
36.                ActiveSheet.PasteSpecial Format:="图片(增强型图元文件)", Link:=False, DisplayAsIcon:=False
    
37.                Set Excel_Shape = ActiveSheet.Shapes(1)
    
38.                Excel_Shape.Copy
    
39.                With ActiveSheet.ChartObjects.Add(0, 0, Excel_Shape.Width, Excel_Shape.Height).Chart
    
40.                   .Paste
    
41.                   m = m + 1
    
42.                   .Export path & "pic" & Split(MyFile, ".")(0) & m & ".png"
    
43.                   .Parent.Delete
    
44.                End With
    
45.                Excel_Shape.Delete
    
46.             Next i
    
47.         End If
    
48.         Myword.Close
    
49.         MyFile = Dir
    
50.     Loop
    
51.     Set Myword = Nothing
    
52.     Word.Quit
    
53.     Set Word = Nothing
    
54. End Sub
    

复制代码