Сохранение изображений из Word на VBA

В данной статье хочу показать 4 способа как экспортировать (сохранить) все изображения из Word документа в файлы в указанную папку на диске с помощью макроса VBA. Обращаю внимание, что речь идет про сохранение не авто-фигур и т.п., а импортированных изображений, которые входят в ворде в коллекцию InlineShapes объекты которой и будем сохранять.

Способ 1. Сохранение изображений из Word в формате EMF

Это самый короткий и быстрый способ экспортировать все изображения из Word-а. Формат изображений EMF (Microsoft Enhanced Metafile) - это медиа-формат, который Microsoft придумал на замену формату WMF. Однако, этот формат не всем приложениям понятен, в этом и минус этого способа.

ExportImages "C:\Мои документы\file.doc", "C:\Export"

Sub ExportImages(DocFile As String, ExportPath As String)
  ' Открываем документ
  Set Wrd = CreateObject("Word.Application")
  Set Doc = Wrd.Documents.Open(DocFile)
  ' Цикл по картинкам в документе
  For i = 1 To Doc.InlineShapes.Count
    FileName = ExportPath & "\img" & CStr(i) & ".emf"
    SaveInlineShape FileName, Doc.InlineShapes(i)
  Next i
  ' Закрываем документ
  Doc.Close
  Wrd.Quit False
End Sub

Sub SaveInlineShape(FileName As Variant, iShape As InlineShape)
Dim vData() As Byte
  ' Открываем файл для записи
  Open FileName For Binary Access Write As #1
  ' Записываем данные
  vData = iShape.Range.EnhMetaFileBits
  Put #1, 1, vData
  ' Закрываем файл
  Close #1
End Sub

Способ 2. Распаковка Word файла как архива

Суть идеи в том, что если файл в формате docx, то он будет представлять собой архив, который содержит множество файлов, в т.ч. и папку с изображениями, которые есть в нем. На случай, если файл не в формате docx, макрос открывает его и пересохраняет в формат docx и потом распаковывает его во временную папку.

ExportImages "C:\Мои документы\file.doc", "C:\Export"

Sub ExportImages(DocFile As String, ExportPath As String)
  ' Создаем временную папку
  TmpPath = ExportPath & "\tmp"
  Set FSO = CreateObject("Scripting.FileSystemObject")
  If Not FSO.FolderExists(TmpPath) Then FSO.CreateFolder (TmpPath)
  ' Открываем документ и пересохраняем во временную папку в формате docx (на случай если он был какого-то другого формата)
  DocXFile = TmpPath & "\1.docx"
  Set Wrd = CreateObject("Word.Application")
  Set Doc = Wrd.Documents.Open(DocFile)
  Doc.SaveAs FileName:=DocXFile, FileFormat:=wdFormatXMLDocument
  Doc.Close: Wrd.Quit False
  ' Переименовываем файл в zip
  ZipFile = TmpPath & "\1.zip"
  Name DocXFile As ZipFile
  ' Распаковываем файлы
  Set objShell = CreateObject("Shell.Application")
  Set FilesInZip = objShell.NameSpace(ZipFile).items
  objShell.NameSpace(TmpPath).CopyHere (FilesInZip)
  ' Получаем список картинок, которые теперь находятся в \word\media
  Set sFolder = FSO.GetFolder(TmpPath & "\word\media")
  For Each FileItem In sFolder.Files
    FileCopy FileItem.Path, ExportPath & "\" & FileItem.Name
  Next FileItem
  ' Удаляем временную папку и всё ее содержимое
  Shell "cmd /c rd /S/Q """ & TmpPath & """"
End Sub

Способ 3. Сохранение файла в HTML

Принцип похож на 2-й способ. При сохранении в html формат создается папка, содержащая картинки и другие вложенные файлы и всё, что нужно, это взять из нее изображения. Минус в том, что изображения выгружаются по несколько раз в разных форматах.

ExportImages "C:\Мои документы\file.doc", "C:\Export"

Sub ExportImages(DocFile As String, ExportPath As String)
  ' Создаем временную папку
  TmpPath = ExportPath & "\tmp"
  Set FSO = CreateObject("Scripting.FileSystemObject")
  If Not FSO.FolderExists(TmpPath) Then FSO.CreateFolder (TmpPath)
  ' Открываем файл и пересохраняем во временную папку в формате HTML
  Set Wrd = CreateObject("Word.Application")
  Set Doc = Wrd.Documents.Open(DocFile)
  Doc.SaveAs TmpPath & "\tmp.html", FileFormat:=wdFormatHTML
  Doc.Close: Wrd.Quit False
  ' Получаем список файлов в папке с вложениями tmp.files
  Set sFolder = FSO.GetFolder(TmpPath & "\tmp.files")
  For Each FileItem In sFolder.Files
    If FSO.GetExtensionName(FileItem.Name) = "jpg" Or _
       FSO.GetExtensionName(FileItem.Name) = "gif" Or _
       FSO.GetExtensionName(FileItem.Name) = "png" Then
      ' Копируем только картинки
      FileCopy FileItem.Path, ExportPath & "\" & FileItem.Name
    End If
  Next FileItem
  ' Удаляем временную папку и всё ее содержимое
  Shell "cmd /c rd /S/Q """ & TmpPath & """"
End Sub

Способ 4. Экспорт изображений в формате BMP с использованием буфера обмена

Суть этого метода в том, чтобы скопировать картинку в буфер обмена и затем, используя API функции сохранить из буфера картинку в файл. Одно из преимуществ этого метода в том, что можно сохранить только одну конкретную картинку из Word документа, а не все подряд.

Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Const CF_BITMAP = 2
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
  Size As Long
  Type As Long
  hPic As Long
  hPal As Long
End Type

ExportImages "C:\Мои документы\file.doc", "C:\Export"

Sub ExportImages(DocFile As String, ExportPath As String)
  ' Открываем документ
  Set Wrd = CreateObject("Word.Application")
  Set Doc = Wrd.Documents.Open(DocFile)
  ' Цикл по картинкам в документе
  For i = 1 To Doc.InlineShapes.Count
    Doc.InlineShapes(i).Range.CopyAsPicture
    Clip2File ExportPath & "\" & CStr(i) & ".bmp"
  Next i
  ' Закрываем документ
  Doc.Close
  Wrd.Quit False
End Sub

' Процедуры для работы с буфером обмена

Public Function Clip2File(OutputPath As String)
  Dim strOutputPath As String, oPic As IPictureDisp
  Set oPic = GetClipPicture()
  If Not oPic Is Nothing Then
    SavePicture oPic, OutputPath
    Clip2File = OutputPath
  Else
    Clip2File = ""
    MsgBox "Unable to retrieve bitmap from clipboard"
  End If
End Function

Private Function GetClipPicture() As IPicture
Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, hCopy As Long
  hPicAvail = IsClipboardFormatAvailable(CF_BITMAP)
  If hPicAvail <> 0 Then
    h = OpenClipboard(0&)
    If h > 0 Then
      hPtr = GetClipboardData(CF_BITMAP)
      hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
      h = CloseClipboard
      If hPtr <> 0 Then Set GetClipPicture = CreatePicture(hCopy, 0, CF_BITMAP)
    End If
  End If
End Function

Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
  Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, _
  IPic As IPicture
  Const PICTYPE_BITMAP = 1
  With IID_IDispatch
    .Data1 = &H7BF80980
    .Data2 = &HBF32
    .Data3 = &H101A
    .Data4(0) = &H8B
    .Data4(1) = &HBB
    .Data4(2) = &H0
    .Data4(3) = &HAA
    .Data4(4) = &H0
    .Data4(5) = &H30
    .Data4(6) = &HC
    .Data4(7) = &HAB
  End With
  With uPicInfo
    .Size = Len(uPicInfo)
    .Type = PICTYPE_BITMAP
    .hPic = hPic
    .hPal = 0
  End With
  r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
  Set CreatePicture = IPic
End Function

У каждого из способов экспорта картинок есть свои плюсы и минусы. Самые быстрые в плане производительности скорее всего 1-й и 4-й способы. У 3-го способа есть плюс - сохраняет в файлы не только вставленные картинки, но так же и автофигуры, диаграммы и т.д. Какой из способов удобнее всего для вас - решайте сами.