Split .doc, with a parameterized name

[lamakun]

Hi all,

I am a PHP programmer with no knowledge on VB, so I apologize for my intrusion :). What I need is to split a .doc file with N pages into N different documents, using the first word of each page as the name of the documents. In php it's been kind of an impossible mission but I found this threat in this forum

vbaexpress.com/kb/getarticle.php?kb_id=727

I found the lines where the macro gets the name of each generated document and saves it:

strNewFileName = Replace(docMultiple.FullName, ".doc", "_" & Right$("000" & iCurrentPage, 4) & ".doc")
docSingle.SaveAs strNewFileName 'save the new single-paged document

However I can't even do the (apparently) very little modification needed to change this so the file is saved with the first word of the page as its name.

Anybody would be so kind to help me with this?

Thanks in advance

[fumei]

Could you make a proper link to that article. I tried to find it but....

Not being able to read the original article, I am not sure what is there, but the first thing is that "page" to Word is a very vague notion. Here is a possible solution for you.
Option Explicit

Sub EachPageToDoc()
Dim r As Range
Dim strFirstWord As String
Dim j As Long
Dim var
Dim ThisDoc As Document
Dim TempDoc As Document

Set ThisDoc = ActiveDocument

j = ThisDoc.Range.Information(wdActiveEndAdjustedPageNumber)
Selection.HomeKey Unit:=wdStory

For var = 1 To j
Set r = ThisDoc.Range( _
Start:=ThisDoc.Bookmarks("\page").Range.Start, _
End:=ThisDoc.Bookmarks("\page").Range.End - 1)
strFirstWord = r.Words(1)
Set TempDoc = Documents.Add
With TempDoc
.Range = r
.SaveAs FileName:=ThisDoc.Path & "\" & _
strFirstWord & ".doc"
.Close
End With
Set TempDoc = Nothing
Selection.Start = r.End + 1
Next

End Sub
Demo attached. Click "Each Page To Doc" on the top toolbar.

[lamakun]

Thanks fumei,

I cannot post any link yet. If you get the link and copy paste it in the navigator address bar it should work. Otherwise, please try putting http before.

I have tried the script in this post (the one in the link) and works good for me as a word macro, but does not generate the name as I need.

I have also tested your script but got an error (I may have done something wrong when saving it as a macro as I am a complete newbie with these topics).

Taking the .doc you attach I would like to get 3 different .doc files called PageOne, PageTwo and PageThree. It would be really good if you could change the fileName assignment in the post I send so it gets first word (in a similar way as it does in your script).

Thank you very much!!

[lamakun]

Anyway...I think I will better post the code I am talking about, just in case:

Option Explicit 'This goes in the Declarations section of your code module.
'Hopefully it is already there because you have ticked the 'Require Variable Declaration' _
checkbox. (Tools/Options, Editor tab.)


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

[fumei]

"Taking the .doc you attach I would like to get 3 different .doc files called PageOne, PageTwo and PageThree."

My code, and my demo, works exactly as you say you want things to work. It makes three separate documents.

PageONE.doc
PageTwo.doc
PageTHREE.doc

"I have also tested your script but got an error "

It would be helpful if you state WHAT error.

[fumei]

Oh, it may get an error as when you open from this site it is NOT saved to a local drive. My code works with the local drive path.

Try saving the download (using File > SaveAs) and then execute my code.

[lamakun]

Hi fumei,

I must say I have tried it again and works great. I have just done a couple of tests and, apparently, I get the error when the first line of a page is left blank. If I remove this line and make sure there is a word on every first line it works exactly how I needed.

Thank you very much, you have saved me a lot of headaches!!!

[fumei]

Well yes, of course it will return an error. The code attempts to set a string variable with the first word! If there ain't no word, that the code is...in error. As it should be. Why would you want to create a blank document?

So...

This can be easily error trapped. Simply check to see if each Section has a first word. If it does not, then skip making a file of that Section.

For var = 1 To j
Set r = ThisDoc.Range( _
Start:=ThisDoc.Bookmarks("\page").Range.Start, _
End:=ThisDoc.Bookmarks("\page").Range.End - 1)
' only process if there is more than one word
' therefore a blank Section gets skipped
If r.Words.Count > 1 Then
strFirstWord = r.Words(1)
Set TempDoc = Documents.Add
With TempDoc
.Range = r
.SaveAs FileName:=ThisDoc.Path & "\" & _
strFirstWord & ".doc"
.Close
End With
Set TempDoc = Nothing
End If
Selection.Start = r.End + 1
Next