Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Word
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 04.10.2020, 22:30   #1
pacha.i
Пользователь
 
Регистрация: 06.10.2017
Сообщений: 32
По умолчанию Разделение Word на отдельные файлы

Здравствуйте. Файл Word с многими страницами разделяется на отдельные файлы по 1 листу следующим кодом
Код:
Sub SplitIntoPages()
Dim docMultiple As Document
Dim docSingle As Document
Dim rngPage As Range
Dim iCurrentPage As Integer
Dim iPageCount As Integer
Dim strNewFileName As String
Application.ScreenUpdating = False 'Makes the code run faster and reduces screen _
flicker a bit.
Set docMultiple = ActiveDocument 'Work on the active document _
(the one currently containing the Selection)
Set rngPage = docMultiple.Range 'instantiate the range object
iCurrentPage = 1
'get the document's page count
iPageCount = docMultiple.Content.ComputeStatistics(wdStatisticPages)
Do Until iCurrentPage > iPageCount
If iCurrentPage = iPageCount Then
rngPage.End = ActiveDocument.Range.End 'last page (there won't be a next page)
Else
'Find the beginning of the next page
'Must use the Selection object. The Range.Goto method will not work on a page
Selection.GoTo wdGoToPage, wdGoToAbsolute, iCurrentPage + 1
'Set the end of the range to the point between the pages
rngPage.End = Selection.Start
End If
rngPage.Copy 'copy the page into the Windows clipboard
  Set docSingle = Documents.Add 'create a new document
  docSingle.Range.Paste 'paste the clipboard contents to the new document 'remove any manual page break to prevent a second blank
  docSingle.Range.Find.Execute Findtext:="^m", ReplaceWith:=""
  'build a new sequentially-numbered file name based on the original multi-paged file name and path
  strNewFileName = Replace(docMultiple.FullName, ".doc", "_" & Right$("000" & iCurrentPage, 4) & ".doc")
  docSingle.SaveAs strNewFileName 'save the new single-paged document
  iCurrentPage = iCurrentPage + 1 'move to the next page
  docSingle.Close 'close the new document rngPage.Collapse wdCollapseEnd 'go to the next page
  Loop 'go to the top of the do loop Application.ScreenUpdating = True 'restore the screen updating
  'Destroy the objects.
  Set docMultiple = Nothing
  Set docSingle = Nothing
  Set rngPage = Nothing
  End Sub
но сохраняет листы в книжной(вертикальной) форме, хотя в изменяемом документе они в альбомной форме. Мне хотелось бы их сохранить как раз в альбомной. Может ли кто то указать на ошибку в коде или посоветовать что то другое.,? спасибо.
pacha.i вне форума Ответить с цитированием
Старый 04.10.2020, 23:13   #2
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Код:
.PageSetup.Orientation = wdOrientLandscape
где-то прописать надо, или для новой книги docSingle или для листа на который вставили, или же надо нововставленные текст выделить и для Selection применить... подберите свой вариант.
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 05.10.2020, 09:50   #3
viter.alex
Балуюсь кодами
Участник клуба
 
Аватар для viter.alex
 
Регистрация: 09.01.2009
Сообщений: 1,837
По умолчанию

Основная ошибка в использовании буфера обмена для переноса текста. Правильнее будет полностью сохранять копию исходного документа и из неё удалять ненужные страницы. Когда-то писал такой скрипт, может найду.
Лучше день потерять — потом за пять минут долететь!©
viter.alex вне форума Ответить с цитированием
Старый 05.10.2020, 13:21   #4
pacha.i
Пользователь
 
Регистрация: 06.10.2017
Сообщений: 32
По умолчанию

Применив
Код:
docSingle.PageSetup.Orientation = wdOrientLandscape
нужная ориентация сохраняется , но каждый новый документ плюс одна страница(файлы по 1,2,3... страницы).
pacha.i вне форума Ответить с цитированием
Старый 05.10.2020, 14:05   #5
viter.alex
Балуюсь кодами
Участник клуба
 
Аватар для viter.alex
 
Регистрация: 09.01.2009
Сообщений: 1,837
По умолчанию

Цитата:
Сообщение от pacha.i Посмотреть сообщение
но каждый новый документ плюс одна страница
потому что ты при копировании копируешь разрывы разделов. Посмотри внимательно.
Лучше день потерять — потом за пять минут долететь!©
viter.alex вне форума Ответить с цитированием
Старый 05.10.2020, 16:33   #6
pacha.i
Пользователь
 
Регистрация: 06.10.2017
Сообщений: 32
По умолчанию

Все. Помучился но решил. Просто я совсем не программист.
Код:
Sub Макрос44()
'
' Макрос44 Макрос
'
'
For i = 1 To ActiveDocument.ComputeStatistics(wdStatisticPages)

    Selection.GoTo What:=wdGoToPage, Which:=wdGoToPage, Name:=Str(i)
    Selection.GoTo What:=wdGoToBookmark, Name:="\page"
    Selection.Copy
    Documents.Add DocumentType:=wdNewBlankDocument
    Selection.PasteAndFormat (wdFormatOriginalFormatting)
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^m"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
     If Selection.PageSetup.Orientation = wdOrientPortrait Then
        Selection.PageSetup.Orientation = wdOrientLandscape
    Else
        Selection.PageSetup.Orientation = wdOrientPortrait
    End If
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    With ActiveDocument.Styles(wdStyleNormal).Font
        If .NameFarEast = .NameAscii Then
            .NameAscii = ""
        End If
        .NameFarEast = ""
    End With
    With ActiveDocument.PageSetup
        .LineNumbering.Active = False
        .Orientation = wdOrientLandscape
        .TopMargin = CentimetersToPoints(1.5)
        .BottomMargin = CentimetersToPoints(3)
        .LeftMargin = CentimetersToPoints(2)
        .RightMargin = CentimetersToPoints(2)
        .Gutter = CentimetersToPoints(0)
        .HeaderDistance = CentimetersToPoints(1.25)
        .FooterDistance = CentimetersToPoints(1.25)
        .PageWidth = CentimetersToPoints(29.7)
        .PageHeight = CentimetersToPoints(21)
        .FirstPageTray = wdPrinterDefaultBin
        .OtherPagesTray = wdPrinterDefaultBin
        .SectionStart = wdSectionContinuous
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .VerticalAlignment = wdAlignVerticalCenter
        .SuppressEndnotes = False
        .MirrorMargins = False
        .TwoPagesOnOne = False
        .BookFoldPrinting = False
        .BookFoldRevPrinting = False
        .BookFoldPrintingSheets = 1
        .GutterPos = wdGutterPosLeft
    End With
    Selection.Find.Execute Replace:=wdReplaceA11
    ActiveDocument.SaveAs2 FileName:="Ворд" + Str(i) + ".docx", FileFormat:= _
        wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
        :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
        :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False, CompatibilityMode:=14
    ActiveWindow.Close
    Next i
End Sub
pacha.i вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Файлы: Составить программу, которая перепишет фамилии в отдельные файлы в соответствии с названием группы Гульвира Помощь студентам 1 23.05.2013 10:04
Разбиение программы на отдельные файлы Митовей Общие вопросы C/C++ 18 08.04.2012 21:10
Разделение слова на отдельные символы,вычисление их количества tagantroy Паскаль, Turbo Pascal, PascalABC.NET 2 18.07.2011 00:39
Разделение программы на отдельные модули (Паскаль) Olya1 Помощь студентам 1 08.07.2011 11:25