怎么用ＶＢＡ把ＷＯＲＤ里的所有图片另存成文件？？

pili_99

　　怎么用ＶＢＡ把ＷＯＲＤ里的所有图片另存成文件？？谢谢

小fisher

Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
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 wFormat As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long

Public iClipBoardFormatNumber As Long
Enum picFormat
    pic_GIFformat = 1
    pic_jpgformat = 2
    pic_pngformat = 3
End Enum

Sub savePic(shp As Shape, picFormat As picFormat, sFileName As String)
'这个过程把工作表中的shape对象另存为图像文件，需要指定要导出的shape对象 - shp
'导出文件格式 - picFormat（有1,2,3三种选择，分别代表gif，jpg和png格式），目标文件名 - sFileName

    Set fs = Nothing
    Dim nClipsize As Long
    Dim hMem As Long
    Dim lpData As Long
    Dim sdata() As Byte

    shp.Select
    Selection.Copy

   
    OpenClipboard 0&
    If iClipBoardFormatNumber = 0 Then
        For i = 40000 To 60000
            If IsClipboardFormatAvailable(i) And IsClipboardFormatAvailable(i + 1) And IsClipboardFormatAvailable(i + 2) And IsClipboardFormatAvailable(i + 3) Then
                iClipBoardFormatNumber = i
                Exit For
            End If
        Next
    End If
On Error GoTo myerror:
    hMem = GetClipboardData(iClipBoardFormatNumber + picFormat)
    If CBool(hMem) Then
        nClipsize = GlobalSize(hMem)
        lpData = GlobalLock(hMem)
        If lpData <> 0 Then
            ReDim sdata(0 To nClipsize) As Byte
            CopyMemory sdata(0), ByVal lpData, nClipsize
            Set fs = CreateObject("Scripting.FileSystemObject")
            If fs.fileExists(sFileName) Then
                Kill sFileName
            End If

            Open sFileName For Binary As #1
                Put #1, , sdata
            Close #1
        End If
        GlobalUnlock hMem
    Else
        GoTo myerror
    End If

    EmptyClipboard
    CloseClipboard
    Exit Sub
myerror:
    GlobalUnlock hMem
    EmptyClipboard
    CloseClipboard
    MsgBox "export failed!"
End Sub

Sub test()
CloseClipboard
    For i = 1 To ThisDocument.Shapes.Count
        savePic ThisDocument.Shapes(i), pic_GIFformat, ThisDocument.Path & "\shape" & i & ".gif"
        savePic ThisDocument.Shapes(i), pic_jpgformat, ThisDocument.Path & "\shape" & i & ".jpg"
        savePic ThisDocument.Shapes(i), pic_pngformat, ThisDocument.Path & "\shape" & i & ".png"
    Next
End Sub
之后运行test()看看效果吧

小fisher

传统方法是将文档另存为htm,然后在相同名称的目录下找图片.

hao123

小fisher:您提供的ＶＢＡ代码生成的图片背景为黑色,能否以白色为背景,不然生成的图片用起来不爽,能否改进一下．

小fisher

生成Gif吧,那样没有图像的部分是透明的

hao123

如果是将选定的对象存为图片代码该如何写?

konggs

xuweiqun兄：

为什么不放上来，让我们学习一下呢？

谢谢

守柔

原帖由 pili_99 于 2007-2-1 08:45 发表
　　怎么用ＶＢＡ把ＷＯＲＤ里的所有图片另存成文件？？谢谢

推荐使用〈Word文档规范助理》之导出图片功能。该功能使用GDI+编程方式，支持BMP、PNG、GIF、JPG和TIF五种图片格式，支持用户自定义文件名和设置图片分辨率（DPI）。

冰风萧萧

才知道《Word文档规范助理》是收费软件

liaojj_008

经典，支持