使用VBA如何把WORD中的图片另存为文件？

jlpdgy004

使用VBA如何把WORD中的图片另存为文件？

守柔

我觉得楼主吧，多写几个字，把问题说得清楚一些不好吗？代码要求简洁，可你的要求，是不是可以多描述一下呢？

所有图片另存为一个文件，还是一个图片存为一个文件，是什么格式的文件，还是存为WORD文档？

jlpdgy004

呵呵！

一个图片对象保存为一个图片文件，最好是JPG格式的了！

七叶一枝梅

将word文档另存为html文档，则在与html文档同名的文件夹中有你的图片。

jlpdgy004

我要的是编写VBA代码完成这个工作！

不是要操作的！

[此贴子已经被作者于2005-1-28 16:27:59编辑过]

守柔

请参：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By 守柔(ShouRou)@ExcelHome 2005-1-29 5:56:57 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub Example() Dim MyApp As Integer, aShape As Shape, i As Integer, PicName As String On Error Resume Next Application.ScreenUpdating = False MyApp = Shell("C:\WINNT\system32\MSPAINT.exe", 1) '运行指定绘图程序 For Each aShape In ActiveDocument.Shapes i = i + 1 '累计 PicName = "Pt00" & i & ".JPG" '设置一个文件名 aShape.Select '选中 Selection.Copy '复制 AppActivate MyApp '激活该应用程序 SendKeys "^v", True '发送CTRL+V(粘贴快捷键) SendKeys "%FA", True '打开另存为 SendKeys PicName & "{Enter}", True '保存为*.JPG格式 Next SendKeys "%{F4}", True '退出画图程序 Application.ScreenUpdating = True End Sub '----------------------

cxffxc

楼主为何要将简单的问题复杂化呢？

jlpdgy004

我 有1万个这样的文档，不用VBA，你能做吗？

jlpdgy004

再请教守柔：

图片保存的路径怎么设置啊？

守柔

请参：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By I Love You_Word!@ExcelHome 2005-1-29 11:50:21 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [标准模块-NewMacros]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub Example() Dim MyApp As Integer, aShape As Shape, i As Integer, PicName As String On Error Resume Next Application.ScreenUpdating = False MyApp = Shell("C:\WINNT\system32\MSPAINT.exe", 1) '运行指定绘图程序 For Each aShape In ActiveDocument.Shapes i = i + 1 '累计 PicName = "D:\YinZhang\Pt00" & i & ".JPG" '设置一个路径和文件名 aShape.Select '选中 Selection.Copy '复制 AppActivate MyApp '激活该应用程序 SendKeys "^v{Enter}", True '发送CTRL+V(粘贴快捷键),对出现的对话框进行确认 SendKeys "%FA", True '打开另存为 SendKeys "{Del}", True '清空(此处还起到一个缓冲作用) SendKeys PicName & "{Enter}", True '保存为*.JPG格式 Next SendKeys "%{F4}", True '退出画图程序 Application.ScreenUpdating = True End Sub '----------------------