Разделить файл word на два и больше

pechenkinsa

Есть задача - из одного файла Word создать несколько с задаваемыми названиями.
В принципе решение уже есть готовое - web-страница , только автор требует что-то там перечислить ему на счет...
Кто-нибудь решал такие задачки?

EVPATIY

не совсем понятна постановка задачи. Требуется создать два-три файла из вордовского документа - почему бы не сделать это руками?

pechenkinsa

требуется создать по 10-12 файлов из 89 файлов (т.е. из каждого желательно с использованием стилей (заголовки) или просто меток
руками начинал - здох.

EVPATIY

дык берешь и макрос фигачишь в ворде...

ranet

опиши задачу четко, я тебе код на vba дам

pechenkinsa

Ок.
Есть текст в ворде, предварительно подготовленный - с использованием стиля "заголовок-2" текст структурирован на разделы.
Требуется создать из каждого файла столько файлов, сколько этих заголовков с соотв. названиями - название исходного файла плюс заголовок из первичного файла, причем желательно сохранить все эти файлы в папку с названием исходного файла.
P.S. макросы писать я умею на уровне "изменить имеющееся", так что если мне дадут болванку, я уж с ней справлюсь.

pechenkinsa

up

renozarip

выложи какой-нибудь пример

pechenkinsa

я сейчас на работе, не смогу выложить..
Пример:
Валовой региональный продукт
бла-бла-бла <----- (содержание раздела в новый файл)
Промышленность
бла-бла-бла
Агропромышленный комплекс
бла-бла-бла
Инвестиции
ну и так далее
Транспорт
...
Финансы
Уровень цен
Труд и занятость
Охрана окружающей среды

2424

Число файлов по количеству регионов? )

ranet

держи первое приближение 
Option Explicit

Const strHeadStype As String = "Заголовок 2"

Public Sub SplitDocByHStype

Dim wrdDoc As Document, strFileName As String, pr As Paragraph

Dim blnStartPr As Boolean, lngPrPos As Long, i As Long, j As Long

  blnStartPr = False

  For i = 1 To ThisDocument.Paragraphs.Count - 1

    Set pr = ThisDocument.Paragraphs(i)

    If pr.Style.NameLocal = strHeadStype Then

      If blnStartPr Then

        strFileName = Replace(ThisDocument.Paragraphs(lngPrPos).Range.Sentences(1 vbCr, "")

        If Len(strFileName) > 0 Then

          Set wrdDoc = Documents.Add(Visible:=False)

          For j = lngPrPos To i - 1

            ThisDocument.Paragraphs(j).Range.Copy

            wrdDoc.Paragraphs(wrdDoc.Paragraphs.Count).Range.Paste

          Next

          wrdDoc.SaveAs ThisDocument.Path & "\" & strFileName

          wrdDoc.Close

        End If

        lngPrPos = i

      Else

        blnStartPr = True

        lngPrPos = i

      End If

    End If

  Next

End Sub

создает файлы в той-же директории где лежит документ, есть две недоработки (лишний перевод строки в новых файлах + не обрабатывает последний "блок").
Рабочий пример -
удачи
P.S. доработать предлагаю самому, что не ясно спрашивай

pechenkinsa

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

Fowler

Молоток

pechenkinsa

как заставить макрос в normal.dot работать? и на кнопку в панели или сочетание клавиш навесить? А то в шаблон копируется текст макроса, но на выполнение его никак не пустить

pechenkinsa

все, разобрался - настройка\команда\макросы
Теперь ищу, как в имя создаваемых файлов добавить имя папки, в которой хранится исходный файл

ranet

 

Public Function GetFolderName(strPath As String) As String

Dim i As Long

  i = InStrRev(strPath, "\")

  If i = 0 Then

    GetFolderName = strPath

  Else

    GetFolderName = Right$(strPath, Len(strPath) - i)

  End If

End Function

если захочешь помудрить, то вычленить имя папки из пути можно в одну строку (тоже самое, только запутанней выглядит)
IIf(InStrRev(Path, "\") = 0, Path, Right$(Path, Len(Path) - InStrRev(Path, "\"

P.S при перемещении кода в шаблон Normal, макрос SplitDocByHStype не будет работать должным образом, так как ThisDocument указывает на контекст кода, т.е. на шаблон Normal.dot, в этом конретном случае достаточно поменять ThisDocument на ActiveDocument, в общем случае лучше явно использовать нужный объект:
 Dim wdDoc As Document

  Set wdDoc = Documents.Open(FileName ,...)

  With wdDoc

  '...

  End With

pechenkinsa

можно итоговый код запостить?
я никак не могу разобраться с GetFolderName, да и с Normal.dot тоже не все понятно.
Еще вопрос - если в тексте есть всякие разметки типа графиков, таблиц, разрывов страниц, то этот макрос падает. Можно вылечить?

ranet

редакция вторая. копирует картинки, таблицы, ... далее не проверял 
Option Explicit

Const strHeadStype As String = "Заголовок 2"

Public Sub SplitDocByHStype

Dim wrdDoc As Document, strFileName As String, pr As Paragraph

Dim blnStartPr As Boolean, lngPrPos As Long, i As Long

  blnStartPr = False

  With ThisDocument

    For i = 1 To .Paragraphs.Count - 1

      Set pr = .Paragraphs(i)

      If pr.Style.NameLocal = strHeadStype Then

        If blnStartPr Then

          strFileName = Replace(.Paragraphs(lngPrPos).Range.Sentences(1 vbCr, "")

          If Len(strFileName) > 0 Then

            Set wrdDoc = Documents.Add(Visible:=False)

            .Range(.Paragraphs(lngPrPos).Range.Start, .Paragraphs(i - 1).Range.End).Copy

            wrdDoc.Range.Paste

            wrdDoc.SaveAs .Path & "\" & GetFolderName(.Path) & strFileName & ".doc"

            wrdDoc.Close

          End If

          lngPrPos = i

        Else

          blnStartPr = True

          lngPrPos = i

        End If

      End If

    Next

  End With

End Sub

Public Function GetFolderName(strPath As String) As String

Dim i As Long

  i = InStrRev(strPath, "\")

  If i = 0 Then

    GetFolderName = strPath

  Else

    GetFolderName = Right$(strPath, Len(strPath) - i)

  End If

End Function

P.S. работающий пример, там же
P.S2 если код помещать в normal.dot, то With ThisDocument нужно заменить на With ActiveDocument

pechenkinsa

супер!
то что надо! вот еще разберусь как переменную вставить в текст )
p.s. это что за агрегат такой в примере?

vlfdimir58

barebone

pechenkinsa

Вот что у меня в итоге получилось (из шаблона normal.dot):
  Public Sub SplitDocByHStype

Dim wrdDoc As Document, strFileName As String, pr As Paragraph

Dim blnStartPr As Boolean, lngPrPos As Long, i As Long

  blnStartPr = False

  With ActiveDocument

    For i = 1 To .Paragraphs.Count - 1

      Set pr = .Paragraphs(i)

      If pr.Style.NameLocal = strHeadStype Then

        If blnStartPr Then

          strFileName = Replace(.Paragraphs(lngPrPos).Range.Sentences(1 vbCr, "")

          If Len(strFileName) > 0 Then

            Set wrdDoc = Documents.Add(Visible:=False)

            .Range(.Paragraphs(lngPrPos).Range.Start, .Paragraphs(i - 1).Range.End).Copy

            wrdDoc.Range.Paste

             wrdDoc.Paragraphs(1).Range.Text = GetFolderName(.Path) + Chr$(13) + wrdDoc.Paragraphs(1).Range.Text

            wrdDoc.SaveAs .Path & "\" & strFileName & " " & GetFolderName(.Path) & ".doc", FileFormat:= _

        wdFormatHTML

            wrdDoc.Close

          End If

          lngPrPos = i

        Else

          blnStartPr = True

          lngPrPos = i

        End If

      End If

    Next

  End With

End Sub

Public Function GetFolderName(strPath As String) As String

Dim i As Long

  i = InStrRev(strPath, "\")

  If i = 0 Then

    GetFolderName = strPath

  Else

    GetFolderName = Right$(strPath, Len(strPath) - i)

  End If

End Function

я добавил сохранение в формате htm для удобства последующего слияния файлов и вставку в начало результирующих файлов названия папки
Вопрос - как заставить word2000 сохранять в формате архива mht? wdFormatwebarchive он не распознает, работает только в Word XP
респект `у!
Оставить комментарий
Имя или ник:
Комментарий: