Добавить файлы Word docx, сохраняя их формат в VBA

Question

Я создаю макрос Word, который получает два аргумента: список документов docx и имя нового файла. Цель состоит в том, чтобы макрос вставлял один документ за другим, сохраняя их соответствующий формат, и сохранял как новый документ docx.

Sub Merger(path As String, args () As Variant)
        Dim vArg As Variant
     
        Active Document.Select
        Selection.ClearFormatting

        For Each vArg In args
          ActiveDocument.Content.Words.Last.Select
          Selection.InsertFile:= _ vArg _,Range:="", _ConfirmConversions:= False, Link:=False, Attachment:= False )
          Selection.InsertBreak Type:=wdPageBreak
        Next vArg
      
        ActiveDocument.SaveAs2 File Name=path
        ActiveDocument.Close
        Application.Quit

Обратите внимание, что я вызываю макрос из пустого файла docx.

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

Answer 1

Формат Word не является модульным. Вместо этого рассмотрите возможность создания составного документа, а затем заполнения его вложенными документами. Вот код для создания главного документа из папки, полной вложенных документов:

Sub AssembleMasterDoc()
  Dim SubDocFile$, FolderPath$, Template$
  Dim Counter&
  Dim oFolder As FileDialog
  Dim oBookmark As Bookmark
  Dim oTOC As TableOfContents
'Create a dynamic array variable, and then declare its initial size
  Dim DirectoryListArray() As String
  ReDim DirectoryListArray(1000)
  Template$ = ActiveDocument.AttachedTemplate.Path & Application.PathSeparator & ActiveDocument.AttachedTemplate.Name
'Loop through all the files in the directory by using Dir$ function
  Set oFolder = Application.FileDialog(msoFileDialogFolderPicker)
  With oFolder
    .AllowMultiSelect = False
    If .Show <> 0 Then
      FolderPath$ = .SelectedItems(1)
    Else
      GoTo EndSub
    End If
  End With
  Application.ScreenUpdating = False
  SubDocFile$ = Dir$(FolderPath$ & Application.PathSeparator & "*.*")
  Do While SubDocFile$ <> ""
      DirectoryListArray(Counter) = SubDocFile$
      SubDocFile$ = Dir$
      Counter& = Counter& + 1
  Loop

'Reset the size of the array without losing its values by using Redim Preserve
  ReDim Preserve DirectoryListArray(Counter& - 1)
  WordBasic.SortArray DirectoryListArray()
  ActiveWindow.ActivePane.View.Type = wdOutlineView
  ActiveWindow.View = wdMasterView
  Selection.EndKey Unit:=wdStory
  For x = 0 To (Counter& - 1)
    If IsNumeric(Left(DirectoryListArray(x), 1)) Then
      FullName$ = FolderPath$ & Application.PathSeparator & DirectoryListArray(x)
      Documents.Open FileName:=FullName$, ConfirmConversions:=False
      With Documents(FullName$)
        .AttachedTemplate = Template$
        For Each oBookmark In Documents(FullName$).Bookmarks
          oBookmark.Delete
        Next oBookmark
        .Close SaveChanges:=True
      End With
      Selection.Range.Subdocuments.AddFromFile Name:=FullName$, ConfirmConversions:=False
    End If
  Next x
  For Each oTOC In ActiveDocument.TablesOfContents
    oTOC.Update
  Next oTOC
  ActiveWindow.ActivePane.View.Type = wdPrintView
  Application.ScreenUpdating = True
EndSub:
End Sub

Этот код взят из предыдущего проекта, поэтому вам может не понадобиться весь его, например, обновление нескольких оглавлений.

Не пытайтесь поддерживать и редактировать составные документы. Формат подвержен искажениям. Вместо этого соберите составной документ для печати (или другого использования), а затем выбросьте его.