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

龙族天堂

TO 守柔：

现在的代码有的时候可以生成图片了，有的时候还不行，甚至把WORD中的图片都给删掉了！不怎么稳定！

TO button：

请楼上给个连接好吗？

button

chijanzen先生的例子：

http://www.vba.com.tw/VBAFILE/Shape/C0008.htm

龙族天堂

TO button：

谢谢！已经可以完成这个保存图片的工作了

TO 守柔：

谢谢斑竹这段时间一直关心这个帖子，帮忙解决问题！

代码如下：

声明： Private Declare Function OpenClipboard Lib "User32" (ByVal hWnd As Long) As Long Private Declare Function CloseClipboard Lib "User32" () As Long Private Declare Function GetClipboardData Lib "User32" (ByVal uFormat As Long) As Long Private Declare Function CopyEnhMetaFileA Lib "Gdi32" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long Private Declare Function DeleteEnhMetaFile Lib "Gdi32" (ByVal hdc As Long) As Long

过程：

public sub SavePic()

Application.ScreenUpdating = False Dim WordFilePath WordFilePath = ActiveDocument.Path & "\" & ActiveDocument.Name Dim WordFileName WordFileName = Left(ActiveDocument.Name, InStr(ActiveDocument.Name, ".") - 1) Dim aShape As InlineShape, I As Integer, PicName As String For Each aShape In ActiveDocument.InlineShapes I = I + 1 PicName = ActiveDocument.Path & "\" & WordFileName & I & ".jpg" aShape.Select Selection.Copy OpenClipboard 0 DeleteEnhMetaFile CopyEnhMetaFileA(GetClipboardData(14), PicName) CloseClipboard Next aShape

Application.ScreenUpdating = True

end sub

[此贴子已经被作者于2005-2-22 15:05:53编辑过]

龙族天堂

这个图片是生成了

但是使用PHOTOSHOP无法编辑，不认可这种图片格式

我修改成BMP，GIF都不行！

nKPPXDLb.rar (44.04 KB, 下载次数: 91)

2005-2-22 17:18 上传

点击文件名下载附件

[此贴子已经被作者于2005-2-22 17:15:43编辑过]

gues1688

厉害！

反复调试守柔版主的代码，我知道是什么原因会引起出错了。

原来，画图程序MSPAINT.exe是没有焦点的，在用shell调用时是异步运行的，VBA代码不会等待mspaint.exe启动就继续向下运行，结果可想而知，由于mspaint.exe尚未完全启动，却试图用“AppActivate MyApp“激活画图程序当然就会出错了。解决办法，就是在适当的位置插入一段延时代码。测试代码如下：

Sub test()
Dim pauseTime#, MyApp
MyApp = Shell("mspaint.exe", 1) '运行指定绘图程序MSPAINT.exe，这里的参数1实际上不起作用
pauseTime = Timer + 1
Do While Timer < pauseTime '延时1秒，等待画图程序启动完毕
DoEvents '将控制让给其它程序
Loop
AppActivate MyApp '激活画图程序
End Sub

neng_wu

ub SheetOutJpg()
Dim Newshape As Shape
ActiveSheet.UsedRange.Select
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    ActiveSheet.Paste
     Set Newshape = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
     With ActiveSheet.ChartObjects.Add(1, 1, 1, 1)
         .Width = Newshape.Width
         .Height = Newshape.Height
          Newshape.Copy
         .Chart.Paste
         .Chart.Export ActiveWorkbook.Path & "\Myjpg.jpg"
         .Delete
     End With
     Newshape.Delete
'   MsgBox "恭喜!图片已生成并存放在" & ActiveWorkbook.Path
End Sub

FENGJUN

守柔 发表于 2005-2-20 07:57
这是我在单位机器上运行上述代码后的截图，请看：
也就是说，我家中的电脑与单位的电脑中，运行全部正 ...

Sub xlf()
    Dim MyApp As Integer, aShape As InlineShape, I As Integer, PicName As String
    'On Error Resume Next
    Application.ScreenUpdating = False
    MyApp = Shell("C:\WINDOWS\system32\MSPAINT.EXE", 1)  '运行指定绘图程序
    For Each aShape In ActiveDocument.InlineShapes
        I = I + 1
        PicName = ActiveDocument.Path & "i" & ".jpg"    '设置一个路径和文件名
        aShape.Select  '选中
        Selection.Copy  '复制
        Selection.TypeText Text:="(图片" & I & ")"
        AppActivate MyApp  '激活该应用程序
        SendKeys "^V{Enter}", True    '发送CTRL+V键，对出现的对话框进行确定
        SendKeys "%FS", True   '打开另存为
        SendKeys "{del}", True    '清空，此处还起到一个缓冲作用
        SendKeys PicName & "{enter}", True    '保存为*.jpg格式
    Next
    SendKeys "%{F4}", True    '退出画图程序
    Application.ScreenUpdating = True
End Sub


'我又重新调试了几次,感觉这次的测试与初次测试差异甚大,重新修改了代码,在四个嵌入式图片中运行了六次,全部正常,请楼主继续测试,如有问题,请及时交流.
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By 守柔(ShouRou)@ExcelHome 2005-2-18 4:37:21 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [标准模块-模块2]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub Example()
    Dim MyApp As Long, aShape As InlineShape, I As Integer, PicName As String
    ' On Error Resume Next
    Application.ScreenUpdating = False
    MyApp = Shell("MSPAINT.exe", 1)    '运行指定绘图程序
    Debug.Print MyApp
    For Each aShape In ActiveDocument.InlineShapes
        I = I + 1    '累计
        PicName = ActiveDocument.Path & "\" & I & ".JPG"    '设置一个路径和文件名
        aShape.Select    '选中
        Selection.Copy    '复制
        AppActivate MyApp    '激活该应用程序
        SendKeys "^n", True    '新建
        SendKeys "^v{Enter}", True    '发送CTRL+v(粘贴快捷键),对出现的对话框进行确认
        SendKeys "%fa", True    '打开另存为
        SendKeys PicName & "{Enter}", True    '保存为*.JPG格式
    Next
    SendKeys "%{F4}", True    '关闭画图程序
    Application.ScreenUpdating = True
End Sub   

守柔兄：上面两段代码确如“龙族”所说，出现错误。我的环境：win server 2003 + Office 2007

wfc0537

Sub aaExample()
    Dim MyApp As Integer, aShape As InlineShape, i As Integer, PicName As String
    Application.ScreenUpdating = False
    If Dir("D:\YinZhang\", vbDirectory) = "" Then MkDir "D:\YinZhang\"
    If Dir("D:\YinZhang\*.*") <> "" Then Kill "D:\YinZhang\*.*"
    MyApp = Shell("C:\windows\system32\MSPAINT.exe", 1) '运行指定绘图程序
    For Each aShape In ActiveDocument.InlineShapes
        i = i + 1 '累计
        PicName = "D:\YinZhang\Pt00" & i & ".JPG" '设置一个路径和文件名
        aShape.Select '选中
        Selection.Copy '复制
        pauseTime = Timer + 0.3
        Do While Timer < pauseTime '延时，等待画图程序启动完毕
        DoEvents '将控制让给其它程序
        Loop
        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

补充内容 (2013-8-11 14:33):
Sub aaExample()
    Dim MyApp As Integer, iShape As InlineShape, aShape As Shape, i As Integer, PicName As String
    Application.ScreenUpdating = False
    If Dir("D:\YinZhang\", vbDirectory) = "" Then MkDir "D:\YinZhang\"
    If Dir("D:\YinZhang\*.*") <> "" Then Kill "D:\YinZhang\*.*"
    MyApp = Shell("C:\windows\system32\MSPAINT.exe", 1) '运行指定绘图程序
    For Each iShape In ActiveDocument.InlineShapes
        i = i + 1 '累计
        PicName = "D:\YinZhang\Pt00" & i & ".JPG" '设置一个路径和文件名
        iShape.Select '选中
        Selection.Copy '复制
        pauseTime = Timer + 0.3
        Do While Timer < pauseTime '延时，等待画图程序启动完毕
        DoEvents '将控制让给其它程序
        Loop
        AppActivate MyApp '激活该应用程序
        SendKeys "^v{Enter}", True '发送CTRL+V(粘贴快捷键),对出现的对话框进行确认
        SendKeys "%FA", True '打开另存为
        SendKeys "{Del}", True '清空(此处还起到一个缓冲作用)
        SendKeys PicName & "{Enter}", True '保存为*.JPG格式
    Next
    For Each aShape In ActiveDocument.Shapes
        i = i + 1 '累计
        PicName = "D:\YinZhang\Pt00" & i & ".JPG" '设置一个路径和文件名
        aShape.Select '选中
        Selection.Copy '复制
        pauseTime = Timer + 0.3
        Do While Timer < pauseTime '延时，等待画图程序启动完毕
        DoEvents '将控制让给其它程序
        Loop
        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

fantasyhero

非常感谢各位，最后的wfc0537的代码稍微修改了一下，存为没有白边的真实jpg格式。

…………
        Loop
        AppActivate MyApp '激活该应用程序
        SendKeys "^e1{Tab}1{Enter}" '设置图板原始大小为1x1
        SendKeys "^v{Enter}", True '发送CTRL+V(粘贴快捷键),对出现的对话框进行确认
        SendKeys "%FA", True '打开另存为
        SendKeys "{Del}", True '清空(此处还起到一个缓冲作用)
       SendKeys PicName & "{Tab}j{Enter}", True '保存为真正的*.JPG格式
    Next
…………

chendeyan126

还要注意
1.picname里面不要包含有中文字符，或者说不要包含有键盘上没有的字符。
2.还有通过sendkeys 把输入法变成英文状态。