VBA如何遍历某一个word中的全部图片，把它们一一保存在指定的文件夹中？

x105888

chenlifeng123 发表于 2016-8-27 15:54
分享我的解决办法，谢谢大家和老师。

为什么你的代码执行不了  出现保存对话框后 SendKeys 没有反应

denxh

huang1314wei 发表于 2016-8-28 13:20
你这个代码写的太复杂了，实际上也可以调用excel来导出word当中的图片的原始比例图片

运行宏要求对象不知是怎么回事？

yjwdjfqb

huang1314wei 发表于 2016-8-28 13:20
你这个代码写的太复杂了，实际上也可以调用excel来导出word当中的图片的原始比例图片

老师你好，这个也是关于WORD中VBA的代码
麻烦老师帮我看下，好吧，谢谢你了老师！
https://club.excelhome.net/thread-1621425-1-1.html

zzpsx

huang1314wei 发表于 2016-8-28 13:20
你这个代码写的太复杂了，实际上也可以调用excel来导出word当中的图片的原始比例图片

请教高手，运行您的代码，出现这个，怎么办？

huang1314wei

zzpsx 发表于 2023-1-21 10:43
请教高手，运行您的代码，出现这个，怎么办？

工具--引用--勾选 Microsoft Excel x.x Object Library..

zzpsx

huang1314wei 发表于 2023-1-21 10:54
工具--引用--勾选 Microsoft Excel x.x Object Library..

谢谢高手。您的代码非常好。不过我的电脑上操作，文件夹内有个word，运行代码，图片不能导出到该文件夹内。所以我想了一个办法，新建一个文件夹b，文件夹里再新建一个文件夹a，a文件夹里新建一个word，运行代码，就可以导出图片到文件夹b了。

smiletwo

https://club.excelhome.net/forum.php?mod=viewthread&tid=1642188

smiletwo

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) & Format(m, "000") & "A.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) & Format(m, "000") & "A.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
    

复制代码

smiletwo

huang1314wei 发表于 2016-8-28 13:20
你这个代码写的太复杂了，实际上也可以调用excel来导出word当中的图片的原始比例图片

myshape.reset  可以重置，好像不重置导出的图片也一样清楚

zzpsx

smiletwo 发表于 2023-1-24 16:55

请教高手，这个怎么解决？