Сохранения каждой главы в отдельный файл

[mamed05]

Здравствуйте!
Кто знает есть ли такое дополнение или макрос для Word (желательно для 2007-го), который сохраняет каждую главу из документа в отдельный файл?

[Sasha_Smirnov]

Что, разве трудно выделить главу и перетянуть её на рабстол мышью?

Макрос, конечно же, возможен, но стоит ли так запариваться для одного раза?


Готовый макрос есть — в Вопросах и Ответах.

Осталось автоматизировать выделение глав. И об этом тоже есть кое-что готовое, точнее — тут!

[mamed05]

А париться не надо! Вот поэтому я спрашиваю кто что может предложить уже готовое :-)

Периодически я это делаю, когда закидывая книгу на плеер. А когда книга большая хочется все автоматизировать.

[viter.alex]

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

1. Ищем начало первой главы и запоминаем номер символа, с которого оно начинается.
2. Ищем начало следующей главый. Запоминаем то же самое.
3. Берем часть документа между запомненными позициями и копируем в новый документ.

[mamed05]

viter.alex, тогда можно опираться на оглавление.
Но есть другой вариант, который опознает главу по Стилю (если это проще).
Но я в VBA не щарю. нет времени его изучать.
Есть добровольцы кто возьмется за написание такого макроса?

[viter.alex]

Написать можно. В течение получаса. Дайте файл-пример

[mamed05]

Вот, пожалуйста!

[viter.alex]

Насчет получаса я погорячился. Уложился в час чистого времени. Прежде чем давать код, изложу свои соображеня.

1. Представленный документ имеет содержание и, благодаря этому, его можно спокойно разбить на главы.
2. Стилей в оформлении документа я не обнаружил, только отдельное форматирование.
3. Макрос сделал основываясь на форматировании.
4. После работы макроса некоторые файлы будут пустыми. Это из-за того, что в тексте есть места с форматированием как у начала главы, но не содержащие текста (приложения, например).

Как он работает. Нужно поставить курсор в начало названия первой главы и запустить макрос. Макрос ищет строки, совпадающие по цвету с текстом, в котором находится курсор. ЭТи строки считаются заголовками. Затем текст, который находится между этими строками, сохраняется в отдельный файл. Комментарии в макросе описывают его работу

Option Explicit

Sub DivideToChapters()
  'Отключаем обновление экрана
  Application.ScreenUpdating = False
  On Error Resume Next
  'Запоминаем основной документ в переменную
  Dim oMainDoc As Document: Set oMainDoc = ActiveDocument 'Документ с текстом
  'Запоминаем содержимое документа от положения курсора и до конца документа
  Dim oRng As Range: Set oRng = oMainDoc.Range(Selection.Range.Start, oMainDoc.Range.End)
  'Создаем новый документ и запоминаем его переменную. В этот новый документ будет копироваться _
  текст из каждой главы и сохраняться под своим именем
  Dim oNewDoc As Document: Set oNewDoc = Documents.Add
  'Переменные для работы: путь к каталогу, объект для скриптов, счетчик глав, имя главы
  Dim sPath$, FSO, counter%, sName$
  'Путь к каталогу, в который будут сохраняться главы. Имя каталога совпадает с именем файла
  sPath = oMainDoc.Path & Application.PathSeparator & Mid(oMainDoc.Name, 1, InStrRev(oMainDoc.Name, ".") - 1)
  'Создаем каталог на диске
  Set FSO = CreateObject("Scripting.FileSystemObject")
  FSO.CreateFolder sPath
  'Если каталог уже создан, то пропускаем ошибку
  If Err.Number = 5 Then Err.Clear
  Dim iStart&, iEnd& 'Переменные для хранения начала и конца главы
  iStart = oRng.Start
  'Производим поиск в документе по цвету текста. Цвет берем из первого символа после курсора.
  With oRng.Find
    .Font.Color = oMainDoc.Range(iStart, iStart + 1).Font.Color
    'Если текст с таким цветом найден
    While .Execute
      If .Parent.Start <> iStart Then 'Отсекаем строку в которой находится курсор
        counter = counter + 1
        iEnd = .Parent.Start 'Конец главы
        oMainDoc.Range(iStart, iEnd).Copy 'Копируем главу
        oNewDoc.Range.Paste 'Вставляем в новый документ
        oNewDoc.SaveAs sPath & Application.PathSeparator & counter & " " & sName & ".txt", wdFormatText 'Сохраняем как обычный текст
        iStart = iEnd 'Конец предыдущей главы делаем началом следующей
      End If
      sName = Trim(Replace(.Parent.Text, vbCr, "")) 'Название главы
    Wend
    'Сохранение последней главы (до конца документа)
    oMainDoc.Range(iStart, oMainDoc.Range.End).Copy
    oNewDoc.Range.Paste
    oNewDoc.SaveAs sPath & Application.PathSeparator & counter + 1 & " " & sName & ".txt", wdFormatText, addtorecentfiles:=False
  End With
    oNewDoc.Close False 'Закрываем документ
    Application.ScreenUpdating = True: Application.ScreenRefresh 'Обновляем экран
End Sub

Пожелания пишите. Макрос требует доработки.

[Sasha_Smirnov]

Интересно, на форуме сделают тег VB или я раньше уйду на пенсию?