Mrrrr's Forum (VIEW ONLY)
Un forum care ofera solutii pentru unele probleme legate in general de PC. Pe langa solutii, aici puteti gasi si alte lucruri interesante // A forum that offers solutions to some PC related issues. Besides these, here you can find more interesting stuff.
Lista Forumurilor Pe Tematici
Mrrrr's Forum (VIEW ONLY) | Reguli | Inregistrare | Login

POZE MRRRR'S FORUM (VIEW ONLY)

Nu sunteti logat.
Nou pe simpatie:
Alexanndra1994
Femeie
23 ani
Bucuresti
cauta Barbat
23 - 42 ani
Mrrrr's Forum (VIEW ONLY) / Tutoriale si Ghiduri Utile // Tutorials and useful guides / [WORD] Split Current Document into Pages [VBA] Moderat de TRaP, TonyTzu
Autor
Mesaj Pagini: 1
TRaP
Moderator

Inregistrat: acum 6 ani
Postari: 787
Source:


Sub SplitDocIntoPages()

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

' @ @ @ @ @ @ @ @ the number of pages to split by @ @ @ @ @ @ @ @
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.PageSetup.Orientation = wdOrientLandscape

If rngPage.PageSetup.Orientation = wdOrientLandscape Then
    docSingle.PageSetup.Orientation = wdOrientLandscape
Else
    docSingle.PageSetup.Orientation = wdOrientPortrait
End If

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:=""
docSingle.Range.Find.Execute FindText:="^m", ReplaceWith:=""

'get the header
docSingle.Sections(1).Headers(wdHeaderFooterPrimary).Range.FormattedText = _
    rngPage.Sections(1).Headers(wdHeaderFooterPrimary).Range.FormattedText
'get the footer
docSingle.Sections(1).Footers(wdHeaderFooterPrimary).Range.FormattedText = _
    rngPage.Sections(1).Footers(wdHeaderFooterPrimary).Range.FormattedText

'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


pus acum 4 ani
   
Pagini: 1  

Mergi la