Копировать заголовки и содержание в новый документ - PullRequest
Новая
       8

Копировать заголовки и содержание в новый документ

0 голосов
/ 14 февраля 2020

Я пытаюсь создать аудиокнигу с несколькими треками, чтобы легко перемещаться по книге, пока я занимаюсь другими вещами, такими как вождение или тренировка. Единственный способ, которым я могу подумать, это сделать каждый заголовок и его содержимое в отдельном документе. Я использовал выбор заголовков и опцию контента, но для этой опции нет ярлыка. Вы должны щелкнуть по нему каждый раз. все, на что я смотрел онлайн, не делает то, что я хочу. есть ли способ выбрать каждый заголовок и содержимое, скопировать его в новый документ, сохранить его как TXT, чтобы каждый заголовок и содержимое находились в своем собственном документе?

Выберите заголовок и содержимое

enter image description here

1 Ответ

0 голосов
/ 22 февраля 2020

Вы можете использовать макрос, подобный следующему, для разделения документа на уровне заголовка 1: 

Sub SplitDocumentByHeading()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document, Rng As Range, i As Long
Dim StrTmplt As String, StrNm As String, StrEx As String, lFmt As Long
Set DocSrc = ActiveDocument
With DocSrc
  StrTmplt = .AttachedTemplate.FullName
  StrNm = Split(.FullName, ".doc")(0)
  StrEx = Split(.FullName, ".doc")(1)
  lFmt = .SaveFormat
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Style = wdStyleHeading1
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute
    End With
    Do While .Find.Found
      i = i + 1
      Set Rng = .Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
      Set DocTgt = Documents.Add(Template:=StrTmplt, Visible:=False)
      With DocTgt
        .Range.FormattedText = Rng.FormattedText
        .SaveAs2 FileName:=StrNm & "_" & Format(i, "00") & ".txt", Fileformat:=wdFormatText, AddToRecentFiles:=False
        .Close
      End With
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
End With
Set DocTgt = Nothing: Set Rng = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub

Для разбиения его на уровне подзаголовка потребуется более сложный код.

...