How do I extract a page from word and insert into a new word document using VB

  • Thread starter Thread starter Adam Faulkner via DotNetMonster.com
  • Start date Start date
A

Adam Faulkner via DotNetMonster.com

I want to create a method within a class that opens a Microsoft Word 2000
Document and has the facility to Create a new word document and then extract
a Page that exists within the original Word Document and save it to a new
Word Document.

I would need to generate a loop for each page found within a word document to
create a new word document and insert the existing page into the new word
document and then save as a new word document.

Any recommendations would be appreciated.

Regards
Adam Faulkner
Croner Software
 
Adam -

Here is some code you can use. I'm not terribly impressed with it, but it
works. Call the routine with:

ParseWordDoc(SourceFilename, DestinationFilename)

Where SourceFilename is the file you are going to extract pages from, and
DestinationFilename is the the base filename you are going to create; for
instance, "Page" would create Page1.doc, Page2.doc, Page3.doc, etc.

The actual code to do the work:

Private Sub ParseWordDoc(ByVal Filename As String, ByVal NewFileName As
String)
Dim WordApp As Microsoft.Office.Interop.Word.Application = New
Microsoft.Office.Interop.Word.Application
Dim BaseDoc As Microsoft.Office.Interop.Word.Document
Dim DestDoc As Microsoft.Office.Interop.Word.Document

Dim intNumberOfPages As Integer
Dim intNumberOfChars As String
Dim intPage As Integer

'Word Constants
Const wdGoToPage = 1
Const wdStory = 6
Const wdExtend = 1
Const wdCharacter = 1

'Show WordApp
WordApp.ShowMe()

'Load Base Document
BaseDoc = WordApp.Documents.Open(Filename)
BaseDoc.Repaginate()

'Loop through pages
intNumberOfPages = BaseDoc.BuiltInDocumentProperties("Number of
Pages").value
intNumberOfChars = BaseDoc.BuiltInDocumentProperties("Number of
Characters").value

For intPage = 1 To intNumberOfPages
If intPage = intNumberOfPages Then
WordApp.Selection.EndKey(wdStory)
Else
WordApp.Selection.GoTo(wdGoToPage, 2)
Application.DoEvents()

WordApp.Selection.MoveLeft(Unit:=wdCharacter, Count:=1)
End If

Application.DoEvents()

WordApp.Selection.HomeKey(wdStory, wdExtend)
Application.DoEvents()

WordApp.Selection.Copy()
Application.DoEvents()

'Create New Document
DestDoc = WordApp.Documents.Add
DestDoc.Activate()
WordApp.Selection.Paste()
DestDoc.SaveAs(NewFileName & intPage.ToString & ".doc")
DestDoc.Close()
DestDoc = Nothing

WordApp.Selection.GoTo(wdGoToPage, 2)
Application.DoEvents()

WordApp.Selection.HomeKey(wdStory, wdExtend)
Application.DoEvents()

WordApp.Selection.Delete()
Application.DoEvents()
Next

BaseDoc.Close(False)
BaseDoc = Nothing

WordApp.Quit()
WordApp = Nothing
End Sub
End Class
 
Jay

The code has provided a great step toward what we want to achieve, however is
it possible on the selection method of word to include headers and footers of
the page when the selection is copied.

Regards
Adam Faulkner
Croner Software

Jay said:
Adam -

Here is some code you can use. I'm not terribly impressed with it, but it
works. Call the routine with:

ParseWordDoc(SourceFilename, DestinationFilename)

Where SourceFilename is the file you are going to extract pages from, and
DestinationFilename is the the base filename you are going to create; for
instance, "Page" would create Page1.doc, Page2.doc, Page3.doc, etc.

The actual code to do the work:

Private Sub ParseWordDoc(ByVal Filename As String, ByVal NewFileName As
String)
Dim WordApp As Microsoft.Office.Interop.Word.Application = New
Microsoft.Office.Interop.Word.Application
Dim BaseDoc As Microsoft.Office.Interop.Word.Document
Dim DestDoc As Microsoft.Office.Interop.Word.Document

Dim intNumberOfPages As Integer
Dim intNumberOfChars As String
Dim intPage As Integer

'Word Constants
Const wdGoToPage = 1
Const wdStory = 6
Const wdExtend = 1
Const wdCharacter = 1

'Show WordApp
WordApp.ShowMe()

'Load Base Document
BaseDoc = WordApp.Documents.Open(Filename)
BaseDoc.Repaginate()

'Loop through pages
intNumberOfPages = BaseDoc.BuiltInDocumentProperties("Number of
Pages").value
intNumberOfChars = BaseDoc.BuiltInDocumentProperties("Number of
Characters").value

For intPage = 1 To intNumberOfPages
If intPage = intNumberOfPages Then
WordApp.Selection.EndKey(wdStory)
Else
WordApp.Selection.GoTo(wdGoToPage, 2)
Application.DoEvents()

WordApp.Selection.MoveLeft(Unit:=wdCharacter, Count:=1)
End If

Application.DoEvents()

WordApp.Selection.HomeKey(wdStory, wdExtend)
Application.DoEvents()

WordApp.Selection.Copy()
Application.DoEvents()

'Create New Document
DestDoc = WordApp.Documents.Add
DestDoc.Activate()
WordApp.Selection.Paste()
DestDoc.SaveAs(NewFileName & intPage.ToString & ".doc")
DestDoc.Close()
DestDoc = Nothing

WordApp.Selection.GoTo(wdGoToPage, 2)
Application.DoEvents()

WordApp.Selection.HomeKey(wdStory, wdExtend)
Application.DoEvents()

WordApp.Selection.Delete()
Application.DoEvents()
Next

BaseDoc.Close(False)
BaseDoc = Nothing

WordApp.Quit()
WordApp = Nothing
End Sub
End Class
I want to create a method within a class that opens a Microsoft Word 2000
Document and has the facility to Create a new word document and then
Click to expand...
[quoted text clipped - 12 lines]
Adam Faulkner
Croner Software
Click to expand...
Click to expand...
 
Adam Faulkner via DotNetMonster.com said:
Jay

The code has provided a great step toward what we want to achieve, however
is
it possible on the selection method of word to include headers and footers
of
the page when the selection is copied.
Click to expand...

Something like

ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader ' (or
Footer)
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Copy

may do it. Note that headers and footers extend over multiple pages.
 
Back
Top