Vba word сохранить все

В данной статье хочу показать 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)
  ' Получаем список картинок, которые теперь находятся в wordmedia
  Set sFolder = FSO.GetFolder(TmpPath & "wordmedia")
  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-го способа есть плюс — сохраняет в файлы не только вставленные картинки, но так же и автофигуры, диаграммы и т.д. Какой из способов удобнее всего для вас — решайте сами.

A couple quick things will get you to a solution.

The first is to loop through the worksheets in your workbook, like this:

Dim ws As Worksheet
For Each ws in ThisWorkbook.Sheets
    Debug.Print "The used range is " & ws.UsedRange.Address
Next ws

The next part is to understand how adding content to a Word document is accomplished. The main concept involves where the insertion point for the document is located — generally this is the current Selection.

When you cut and paste into a Word document, the content just pasted is still «selected». This means that any subsequent paste will effectively replace what you just inserted. So you have to move the selection point to the end of the document.

Putting it all together in an example program:

Option Explicit

Public Sub ExcelToWord()
    Dim wb As Workbook
    Set wb = ThisWorkbook

    '--- create the Word document
    Dim objWd As Word.Application
    Set objWd = CreateObject("word.application")
    objWd.Visible = True

    Dim objDoc As Word.Document
    Set objDoc = objWd.Documents.Add
    objDoc.PageSetup.Orientation = 1             '  portrait = 0

    Const wdPageBreak As Long = 7

    Dim ws As Worksheet
    For Each ws In wb.Sheets
        ws.UsedRange.Copy
        objWd.Selection.Paste
        '--- advance the selection point to the end of
        '    the document and insert a page break, then
        '    advance the insertion point past the break
        objDoc.Characters.Last.Select
        objWd.Selection.InsertBreak wdPageBreak
        objDoc.Characters.Last.Select
    Next ws
    'objDoc.SaveAs Application.ThisWorkbook.Path & ".dokument.docx"
End Sub