1 Тема от popov360

  • popov360
  • рядовой
  • Неактивен
  • Зарегистрирован: 16.02.2013
  • Сообщений: 2

Тема: Разбивка файла на части по заголовкам

Здравствуйте! smile
Вот возникла у меня такая задача. Есть большой вордовский документ, который условно разбит на части заголовками. Почему условно, потому что заголовки не отформатированы ни как списки, ни как стили. Просто каждый заголовок имеет порядковый номер, введенный вручную, и выделен полужирным шрифтом.
Задача у меня такая. Нужно организовать цикл, который разделит данный файл на части, т.е. заголовок это начало нового файла, и сохранит каждый из них в пдф.
Сам имею опыт работы с vba в экселе, но ни разу не работал с макросами по ворду, поэтому даже и не знаю как начать. Представляю это так, что должен быть цикл, который проходит по словам (абзацам), и если встречает число, совпадающее с счетчиком (порядковым номером заголовка) и выделенное жирным, то распознает сие как начало нового документа.
Как мне кажется задача довольна тривиальная, и у специалистов по любому должно быть припасено такое решение.
Заранее спасибо! smile

2 Ответ от popov360

  • popov360
  • рядовой
  • Неактивен
  • Зарегистрирован: 16.02.2013
  • Сообщений: 2

Re: Разбивка файла на части по заголовкам

В общем у меня кое как получилось smile 

On Error Resume Next
    Set objWSHShell = CreateObject("WScript.Shell")
    DesktopPath = objWSHShell.SpecialFolders("Desktop")
    FullPath = DesktopPath & Foldername
    NameNum = 1
    If Not FolderExists(FullPath) Then MkDir FullPath
    i = 1
    FirstSent = 1
    For Each n In ThisDocument.Sentences
        If n.Bold = True And n.Italic = False And IsNumeric(n.Words(1)) Then
           If i > 1 Then
                LastSent = i - 1
                ThisDocument.Range(ThisDocument.Sentences(FirstSent).Start, ThisDocument.Sentences(LastSent).End).Copy
                Call ExportToPdf("Вопрос №" & NameNum, FullPath)
                FirstSent = i
                NameNum = n.Words(1)
           End If
        End If
        i = i + 1
    Next n
    Set oShell = CreateObject("Wscript.Shell")
    oShell.Run (FullPath)
   application.Quit SaveChanges:=wdDoNotSaveChanges 
End Sub
Sub ExportToPdf(name As String, Path As String)
    Documents.Add DocumentType:=wdNewBlankDocument
    Selection.PasteAndFormat (wdFormatOriginalFormatting)
    ActiveDocument.ExportAsFixedFormat OutputFileName:= _
        Path & name, ExportFormat:=wdExportFormatPDF, _
        OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
        wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent, _
        IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
        wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:= _
        True, UseISO19005_1:=False
    ChangeFileOpenDirectory Path
    Clipboard.Clear
End Sub

Public Function FolderExists(ByVal strPathName As String) As Boolean
Dim DirectoryFound As String
Const errPathNotFound As Integer = 76
On Error GoTo 0
DirectoryFound = Dir(strPathName, vbDirectory)
If (Len(DirectoryFound) = 0 Or Err = errPathNotFound) Then
FolderExists = False
Else
FolderExists = True
End If

3 Ответ от viter.alex

  • Разбивка файла на части по заголовкам
  • viter.alex
  • Модератор
  • Неактивен
  • Откуда: Харьков, Украина
  • Зарегистрирован: 21.12.2009
  • Сообщений: 884
  • Поблагодарили: 140
  • За сообщение: 1

Re: Разбивка файла на части по заголовкам

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

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
Лучше день потерять — потом за пять минут долететь!

Сайтviter.alex