[VBA]如何用VBA实现Word_DOC文档批量导出图片(jpg)文件

如何用VBA实现Word_DOC文档批量导出图片(jpg)文件

最近碰到一个情况，需要从近万个doc文档中提取其中的图片，并以文件（jpg）的形式保存，经过努力完美实现预期目标，现总结如下。笼统地讲，有四种方法

首先，需要区分图片在doc中的存在形式分为两种对象，即为Document下的inlineshape或者shape，从名字可以推测出两种对象的区别，前者是指图片以[嵌入型]的文字环绕方式插入doc文档，后者是指其他的多种文字环绕方式，如[四周型][上下型][浮于文字上方]等；
这两种类型的对象，对图片批量导出的影响不只是对象引用方式的区别，更关乎其对象的特性，这个内容结合具体的实现方式来总结。
接下来，分述一下几种导出图片的方法：

①另存HTML
将doc另存为HTML，即网页格式，该状态下，所有doc中的图片将以ImageXXX.JPG的文件名存在于与HTML文件对应的.file文件夹中。该方法简单粗暴，当需要导出的图片无需过滤等行为时，是个不错的选择。而且这种方法无需考虑文档中图片所属类型，图片都将以原始状态[即图片分辨率参数与图片插入doc时一致，不是指和doc中显示的大小一致]以单文件为例的示例代码：

Sub doc另存为HTML()
Dim WordDOC As Object
Dim Path, Name As String
Set WordDOC = Documents.Open(“C:\Brildo\Test.docx”)
Path = WordDOC.Path
Name = WordDOC.Name
ActiveDocument.SaveAs2 FileName:=Path & “” & Split(Name, “.”)(0), FileFormat:=wdFormatHTML
ActiveDocument.Close (0)
End Sub

②通过Windows API访问粘贴板中的图片数据
基本思路是在doc中找到需要保存的图片，复制到粘贴板后，调用API从粘贴板中抓出数据并另存为。此方法中inlineshape和shape会表现不同的特性，具体讲，就是前者会以原始分辨率输出，后者以doc中所表现的分辨率输出。但相对于第一种方法，可加入图片筛选等行为。下面调用API的代码来自Excel精英论坛的MSMVP——ID:kevinchengcw，实现从单个doc中导出全部图片。

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
  SuppresexternalCodecs 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 AsGdiplusStartupInput, ByVal outputbuf As Long) As Long
Private Declare Function GdiplusShutdown Lib “GDIPlus” (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib “GDIPlus” (ByVal hbm As Long, ByValhpal 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 FileNameAs 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 IsClipboardFormatAvailable Lib “user32” (ByVal wFormat As Integer) AsLong
Private Declare Function GetClipboardData Lib “user32” (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib “user32” (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib “user32” () As Long
Const CF_BITMAP = 2
Sub 通过API访问粘贴板并另存图片数据()
  Dim tSI As GdiplusStartupInput
  Dim lRes As Long
  Dim lGDIP As Long
  Dim lBitmap As Long
  Dim hBitmap As Long
  Dim FileName As String
  Dim inSh As InlineShape, N As Long
  N = 0
  documents.open(“C:\Brildo\Test.docx”)
  For Each inSh In activedocument.InlineShapes
  ‘如果是shape，此处改为activedocument.Shapes，当然inSh的声明也要改
      N = N + 1
      FileName = ThisDocument.Path & “” & Format(N, “000.jpg”)
      inSh.Range.CopyAsPicture
      ‘如果为shape，CopyAsPicture方法无效，可能因为shape本身就是pic，
      ‘所以对于shape直接select，再copy，即以图片形式装入了粘贴板，
      ‘后续操作相同。
      OpenClipboard 0&
      hBitmap = GetClipboardData(CF_BITMAP)
      CloseClipboard
      tSI.GdiplusVersion = 1
      lRes = GdiplusStartup(lGDIP, tSI, 0)
      If lRes = 0 Then
           lRes = GdipCreateBitmapFromHBITMAP(hBitmap, 0, lBitmap)
          If lRes = 0 Then
              Dim tJpgEncoder As GUID
              Dim tParams As EncoderParameters
              CLSIDFromString StrPtr(“{557CF401-1A04-11D3-9A73-0000F81EF32E}”), tJpgEncoder
              tParams.Count = 1
              With tParams.Parameter
                  CLSIDFromString StrPtr(“{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}”), .GUID
                  .NumberOfValues = 1
                  .type = 4
                  .Value = VarPtr(100)
              End With
              lRes = GdipSaveImageToFile(lBitmap, StrPtr(FileName), tJpgEncoder, tParams)
              GdipDisposeImage lBitmap
          End If
          GdiplusShutdown lGDIP
      End If
  Next inSh
End Sub

③通过ADODB实现数据读入和导出
在Word VBA中有一种”EnhMetaFileBits”方法，它返回一个字节数组，该值代表选定文本[Selection（Shape不能range，只能select）或者Range]或文本区域的显示方式的图片表示形式。该方法最大的问题是，EnhMetaFileBits方法本质上将选定区域做图片转换，更像是一种屏幕截图行为，故无论是哪种形式的图片均会丧失原有的分辨率，且因为doc排版关系，将图片周边多余区域一起截图。

Sub 利用ADODB读入并另存图片()
Set ImageStream = CreateObject(“ADODB.Stream”)
For i = 1 To ActiveDocument.InlineShapes.Count
ActiveDocument.InlineShapes(i).Select
‘若为shape，需要在此select，并将Selection.Range.EnhMetaFileBits
‘改为Selection.EnhMetaFileBits
With ImageStream
  .Type = 1
  .Open
  .Write Selection.Range.EnhMetaFileBits
  .SaveToFile “D:\Brildo” & i & “.jpg”
  .Close
End With
Next i
Set ImageStream = Nothing
End Sub

④通过复制到Excel后，用Excel的ChartObjects对象的相关方法实现输出
在Excel中，ChartObjects是由指定的图表工作表、对话框工作表或工作表上的所有 ChartObject 对象组成的集合。每个 ChartObject 对象都代表一个嵌入图表。ChartObject 对象充当 Chart 对象的容器。ChartObject 对象的属性和方法控制工作表上嵌入图表的外观和大小。
该方法的亮点是：当利用PasteSpecial将数据从doc传递到xls中时，无论原来对象的类型，都可以靠PasteSpecial实现其分辨率的控制，示例中的”图片(增强型图元文件)”即为原始分辨率复制。以下代码是直接在ExcelVBA中实现的，其中对Word中的对象引用已做处理。

Sub 复制到Excel后输出()
Dim Excel_Shape As Shape
Dim i As Integer
Dim Word, Myword As Object
Set Word = CreateObject(“word.application”)
Set Myword = Word.documents.Open(“C:\Users\Brildo\Desktop\test.doc”)
Word.Visible = True
Application.DisplayAlerts = False ‘从doc到xls的复制过程可能会报错，故加此句
For i = 1 To Myword.Shapes.Count
  Myword.Shapes(i).Select
  Word.Selection.Copy
  ActiveSheet.Cells(i, 1).Activate
  ActiveSheet.PasteSpecial Format:=”图片(增强型图元文件)”, Link:=False, DisplayAsIcon:=False
  Set Excel_Shape = ActiveSheet.Shapes(1)’因为当单个doc中存在图片量过多，均复制到xls中造成数据量过大，
  ‘这里采用了复制一个进入xls，再另存图片后，立即删除xls中的图片数据，所以遍历时，index永远是1
  Excel_Shape.Copy
  With ActiveSheet.ChartObjects.Add(0, 0, Excel_Shape.Width, Excel_Shape.Height).Chart
      .Paste
      .Export ThisWorkbook.Path & “” & i & “.jpg”
      .Parent.Delete’删除第二次复制产生的数据
  End With
  Excel_Shape.Delete’删除第一次复制产生的数据
Next i
End Sub

综上所述，如果只是导出图片，而对其分辨率没有明确要求，那么多种方法均能很好的实现目标。否则，就必须考虑其在doc中所属对象类型了，或者选择特定方法。从本质上看，两种对象类型在doc中都存储了完整的数据，那么区别只是在于特定的复制方法是否能暴露出其全部的数据。