将Word中的图片保存为一个文件

近日被朋友问到如何在Word中把某个插入的图片对象保存为单独的文件。原先他的做法是去调用API，大致的代码是如下面的

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
    GUID As GUID
    NumberOfValues As Long
    type As Long
    Value As Long
End Type
Private Type EncoderParameters
    count As Long
    Parameter As EncoderParameter
End Type

Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal Str As Long, id As GUID) As Long
Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb As Long) As Long
Private Sub SavePic(ByVal pict As StdPicture, ByVal FileName As String, PicType As String, _
                    Optional ByVal Quality As Byte = 80, _
                    Optional ByVal TIFF_ColorDepth As Long = 24, _
                    Optional ByVal TIFF_Compression As Long = 6)
   Screen.MousePointer = vbHourglass
   Dim tSI As GdiplusStartupInput
   Dim lRes As Long
   Dim lGDIP As Long
   Dim lBitmap As Long
   Dim aEncParams() As Byte
   On Error GoTo ErrHandle:
   tSI.GdiplusVersion = 1   ' 初始化 GDI+
   lRes = GdiplusStartup(lGDIP, tSI)
   If lRes = 0 Then     ' 从句柄创建 GDI+ 图像
      lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
      If lRes = 0 Then
         Dim tJpgEncoder As GUID
         Dim tParams As EncoderParameters    '初始化解码器的GUID标识
         Select Case PicType
         Case ".jpg"
            CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
            tParams.count = 1                               ' 设置解码器参数
            With tParams.Parameter ' Quality
               CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID    ' 得到Quality参数的GUID标识
               .NumberOfValues = 1
               .type = 4
               .Value = VarPtr(Quality)
            End With
            ReDim aEncParams(1 To Len(tParams))
            Call CopyMemory(aEncParams(1), tParams, Len(tParams))
        Case ".png"
             CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
             ReDim aEncParams(1 To Len(tParams))
        Case ".gif"
             CLSIDFromString StrPtr("{557CF402-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
             ReDim aEncParams(1 To Len(tParams))
        Case ".tiff"
             CLSIDFromString StrPtr("{557CF405-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
             tParams.count = 2
             ReDim aEncParams(1 To Len(tParams) + Len(tParams.Parameter))
             With tParams.Parameter
                .NumberOfValues = 1
                .type = 4
                 CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .GUID    ' 得到ColorDepth参数的GUID标识
                .Value = VarPtr(TIFF_Compression)
            End With
            Call CopyMemory(aEncParams(1), tParams, Len(tParams))
            With tParams.Parameter
                .NumberOfValues = 1
                .type = 4
                 CLSIDFromString StrPtr("{66087055-AD66-4C7C-9A18-38A2310B8337}"), .GUID    ' 得到Compression参数的GUID标识
                .Value = VarPtr(TIFF_ColorDepth)
            End With
            Call CopyMemory(aEncParams(Len(tParams) + 1), tParams.Parameter, Len(tParams.Parameter))
        Case ".bmp"                                               '可以提前写保存为BMP的代码，因为并没有用GDI+
            SavePicture pict, FileName
            Screen.MousePointer = vbDefault
            Exit Sub
        End Select
         lRes = GdipSaveImageToFile(lBitmap, StrPtr(FileName), tJpgEncoder, aEncParams(1))           '保存图像
         GdipDisposeImage lBitmap       ' 销毁GDI+图像
      End If
      GdiplusShutdown lGDIP              '销毁 GDI+
   End If
   Screen.MousePointer = vbDefault
   Erase aEncParams
   Exit Sub
ErrHandle:
    Screen.MousePointer = vbDefault
    MsgBox "在保存图片的过程中发生错误:" & vbCrLf & vbCrLf & "错误号:  " & err.Number & vbCrLf & "错误描述:  " & err.Description, vbInformation Or vbOKOnly, "错误"
End Sub

这个代码在VB 6.0中确实能工作。但换到Word里面去死活不行。我当时分析猜想就是word那个图片对象所得到的字节可能会不会有些特殊的内容。后来我找到另外一个更加合适的方式解决了

1. 首先添加对ADO的引用

2. 使用下面的代码去保存图片

Public Sub SaveImage()

Dim ImageStream As Object

Set ImageStream = CreateObject("ADODB.Stream")

With ImageStream

.type = 1 ' adTypeBinary

.Open

.Write (Selection.EnhMetaFileBits)

.SaveToFile ("C:\Test.bmp")

.Close

End With

Set ImageStream = Nothing

End Sub

这里有几个关键点

2.1 使用ADODB.Stream ，其实是一个内存流，这个流里面当然可以放任何东西。

2.2 如何取得Word文档中当前选中的图像对象所包含的字节呢。很好的一个消息是,word中通过Selection.EnhMetaFileBits可以返回