Saving Word pages. 1

[dodge20]

Is is possible to save each page in a word document as a new document? For example I have a document called testdoc with 250 pages. What I want to do is automatically save each individual page as a new document. So page 1 would be testdoc1.doc and page 2 would be testdoc2.doc and so on. I am not that picky about how it is named.

Thanks

Dodge20

 

[fumei]

Yes. The following creates individual files for each page of a document. It add "Pagepagenumberof" to the original filename, and saves them into the same folder holding the original file. So page 4 of "test.doc" will be saved as "Page4oftest.doc"

NOTE: this creates a document for every page, including blank ones. It could be tweaked to determine blank pages.

Sub EachPageDoc()

Dim aDoc As Document
Dim lngPageCount As Long, lngCurrentPage As Long
Dim var As Variant

Set aDoc = ActiveDocument
lngCurrentPage = 1
  ' use constant for number of pages
lngPageCount = aDoc.BuiltInDocumentProperties(14)

' turn off screen updating otherwise
' your brain will turn into mush
    Application.ScreenUpdating = False

'  go to top of doc
    Selection.HomeKey Unit:=wdStory
For var = 1 To lngPageCount

' make selection of page, and copy it
    aDoc.Bookmarks("\page").Select
    Selection.Copy

' make new document, paste, and save
    Application.Documents.Add
      Selection.PasteSpecial
        ActiveDocument.SaveAs FileName:=aDoc.Path & _
            Application.PathSeparator & "Page" & lngCurrentPage & "of" & aDoc.Name
        ActiveDocument.Close


' go to next page
    aDoc.Activate
    Selection.GoTo what:=wdGoToPage, Which:=wdGoToNext, Count:=1, Name:=""
    lngCurrentPage = lngCurrentPage + 1
Next

' turn screen update back on
    Application.ScreenUpdating = True

' release aDoc
    Set aDoc = Nothing

MsgBox "Done."
End Sub

Hope this helps.


Gerry

 

[dodge20]

This is real close, for every page it puts a blank page after it. Can this be eliminated? Also is it possible to save it as a .txt file?

Here is a star for your efforts so far.

Dodge20

 

[dodge20]

2 things to add to my last post. It looks like it just has 1 blank line after each page which causes the new blank page. Also if I can get it to save a .txt then it will eliminate the extra pages altogether.

Dodge20

 

[dodge20]

Ok, I have been doing some research on this and I have found something to convert a doc to txt. I have no experience with VB, so I need some help applying it to fumei's code. Here is what I found

' Convert a Word-compatible format to an other format.
' Parameters:
'  - sFileName is the file to convert
'  - wdFormat is the destination file's format
'  - sNewFileName is the destination file. If not specified the the routine 
' will use the sFileName's path & name
'
' NOTE: requires the Microsoft Word type library
'
' Example: convert from DOC to HTML
'   ConvertWordDocument("C:\Documents\MyWordFile.doc", wdFormatHTML)

Function ConvertWordDocument(ByVal sFilename As String, _
    Optional ByVal wdFormat As WdSaveFormat = wdFormatText, _
    Optional ByVal sNewFileName As String) As Boolean
    Dim iPointer As MousePointerConstants
    Dim sExtension As String
    Dim oWord As New Word.Application

    On Error GoTo ErrHandler
    iPointer = Screen.MousePointer
    
    ' open the file
    oWord.Documents.Open sFilename, False, False, False, , , , , , _
        wdOpenFormatAuto
    
    ' the destination filename if sFileName is sNewFileName is missing
    If Len(sNewFileName) = 0 Then
        sNewFileName = sFilename
        ' remove the actual extension ad add the one specified by sExtension
        If InStr(sNewFileName, ".") > 0 Then sNewFileName = Left$(sNewFileName, _
            InStr(sNewFileName, ".") - 1)
        ' set the extension for the selected destination format
        sExtension = Switch(wdFormat = wdFormatDocument, ".doc", _
            wdFormat = wdFormatDOSText, ".txt", _
            wdFormat = wdFormatDOSTextLineBreaks, ".txt", _
            wdFormat = wdFormatEncodedText, ".txt", wdFormat = wdFormatHTML, _
            ".htm", wdFormat = wdFormatRTF, ".rtf", wdFormat = wdFormatTemplate, _
            ".doc", wdFormat = wdFormatText, ".dot", _
            wdFormat = wdFormatTextLineBreaks, ".txt", _
            wdFormat = wdFormatUnicodeText, ".txt")
        ' add the extension to the file name
        sFilename = sFilename & sExtension
    End If
    
    ' save the file
    oWord.ActiveDocument.SaveAs sNewFileName, wdFormat, , , False
    
    ' close Word
    oWord.Quit
    Set oWord = Nothing

    ConvertWordDocument = True
    
ErrHandler:
    ' restore the original mouse pointer
    Screen.MousePointer = iPointer
End Function

Dodge20

 

[dodge20]

I got it to work saving it as a .txt. Thanks Fumei.

Sub EachPageDoc()

Dim aDoc As Document
Dim lngPageCount As Long, lngCurrentPage As Long
Dim var As Variant


Set aDoc = ActiveDocument
lngCurrentPage = 1
  ' use constant for number of pages
lngPageCount = aDoc.BuiltInDocumentProperties(14)

' turn off screen updating otherwise
' your brain will turn into mush
    Application.ScreenUpdating = False

'  go to top of doc
    Selection.HomeKey Unit:=wdStory
For var = 1 To lngPageCount

' make selection of page, and copy it
    aDoc.Bookmarks("\page").Select
    Selection.Copy

' make new document, paste, and save
    Application.Documents.Add
      Selection.PasteSpecial
        ActiveDocument.SaveAs aDoc.Path & Application.PathSeparator & "Page" & lngCurrentPage & "of" & Left(aDoc.Name, Len(aDoc.Name) - 4) & ".txt", wdFormatText

        ActiveDocument.Close


' go to next page
    aDoc.Activate
    Selection.GoTo what:=wdGoToPage, Which:=wdGoToNext, Count:=1, Name:=""
    lngCurrentPage = lngCurrentPage + 1
Next

' turn screen update back on
    Application.ScreenUpdating = True

' release aDoc
    Set aDoc = Nothing

MsgBox "Done."
End Sub

Dodge20

 

[PHV]

In fumei's code, simply replace this:
ActiveDocument.SaveAs FileName:=aDoc.Path & _
Application.PathSeparator & "Page" & lngCurrentPage & "of" & aDoc.Name
By this:
ActiveDocument.SaveAs FileName:=aDoc.Path & _
Application.PathSeparator & "Page" & lngCurrentPage & "of" & aDoc.Name & _
, FileFormat:=wdFormatTextLineBreaks

Hope This Help, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ222-2244

 

[fumei]

Just got aound to checking back. Thanks PHV, you supplied the answer I was going to give.

Yeah, just simply save as a textfile. Sorry, but all that other code you posted, the function for converting, totally unrequired for this solution.

Thanks again PHV! The king of clean and efficient code.





Gerry

 

[PHV]

Thanks fumei for the nice words.

 

[dodge20]

When I tried using PHV's code I got an error message for an invalid character at the underscore before the file format. This is what I used to get it to work.

ActiveDocument.SaveAs aDoc.Path & Application.PathSeparator & "Page" & lngCurrentPage & "of" & Left(aDoc.Name, Len(aDoc.Name) - 4) & ".txt", wdFormatText

Dodge20