MS Access Using VBA Split Word Docx file into separate Doc for Each Page

In Microsoft Access, I want to "read" a Microsoft Word document that was created through a Mail Merge and split it into as many documents as there are pages. I would like to name each document based upon the characters found on each page between two ^'s. Below is some code that was on the .net Experts Exchange forum for doing the split within Word (without the "special" naming). So my first question is this:

In Access, how would I implement the code below?

When I cut and paste the code, the First Reference to WordApp, is colored Red, which leads me to believe I need to do something with the references.

Public Sub ParseDoc(ByVal filename As String)

    Dim WordApp As New Microsoft.Office.Interop.Word.Application
    Dim docMultiple As Microsoft.Office.Interop.Word.Document
    Dim docSingle As Microsoft.Office.Interop.Word.Document
    Dim rngPage As Microsoft.Office.Interop.Word.Range
    Dim iCurrentPage As Integer
    Dim iPageCount As Integer
    Dim strNewFileName As String

    WordApp.Application.ScreenUpdating = False
    docMultiple = WordApp.Documents.Open(filename)



    rngPage = docMultiple.Range
    iCurrentPage = 1
    iPageCount = docMultiple.Content.ComputeStatistics(WdStatistic.wdStatisticPages)

    Do Until iCurrentPage > iPageCount
        If iCurrentPage = iPageCount Or iCurrentPage = iPageCount - 1 Then
            rngPage.End = WordApp.ActiveDocument.Range.End
        Else
            WordApp.Selection.GoTo(WdGoToItem.wdGoToPage, WdGoToDirection.wdGoToAbsolute, iCurrentPage + 2)
            rngPage.End = WordApp.Selection.Start
        End If
        rngPage.Copy()
        docSingle = WordApp.Documents.Add
        docSingle.range.Paste()
        docSingle.range.Find.Execute(Findtext:="^m", ReplaceWith:="")
        strNewFileName = Replace(docMultiple.FullName, ".docx", "_" & Right$("000" & iCurrentPage, 4) & ".docx")
        docSingle.SaveAs (strNewFileName)
        iCurrentPage = iCurrentPage + 1
        docSingle.Close()
        rngPage.Collapse (WdCollapseDirection.wdCollapseEnd)
    Loop

    WordApp.Application.ScreenUpdating = True

    WordApp.Quit()

    docMultiple = Nothing
    docSingle = Nothing
    rngPage = Nothing
    WordApp = Nothing

End Sub

My next question relates to the naming of the files. Below is a snippet of code I had that was renaming some similar pdf documents. How would I search the page contents looking for the string so I can replace using the page number as the file name? So I am really asking how do I load the entire page into the FileContent string variable.

FirstCaret = InStr(1, FileContent, "^")
NextCaret = InStr((FirstCaret + 1), FileContent, "^")
NewName = Mid(FileContent, (FirstCaret + 1), (NextCaret - (FirstCaret + 1)))
Rick RudolphAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Rgonzo1971Commented:
Hi,

pls try
Public Sub ParseDoc(ByVal filename As String)

     Dim WordApp As Object
     Dim docMultiple As Object
     Dim docSingle As Object
     Dim rngPage As Object
     Dim iCurrentPage As Integer
     Dim iPageCount As Integer
     Dim strNewFileName As String
     Set WordApp = CreateObject("Word.Application")

     WordApp.Application.ScreenUpdating = False
     Set docMultiple = WordApp.Documents.Open(filename)



     Set rngPage = docMultiple.Range
     iCurrentPage = 1
     iPageCount = docMultiple.Content.ComputeStatistics(2) '(WdStatistic.wdStatisticPages)

     Do Until iCurrentPage > iPageCount
         If iCurrentPage = iPageCount Or iCurrentPage = iPageCount - 1 Then
             rngPage.End = WordApp.ActiveDocument.Range.End
         Else
            'WdGoToItem.wdGoToPage  WdGoToDirection.wdGoToAbsolute
             WordApp.Selection.GoTo 1, 1, iCurrentPage + 2
             rngPage.End = WordApp.Selection.Start
         End If
         rngPage.Copy
         Set docSingle = WordApp.Documents.Add
         docSingle.Range.Paste
         docSingle.Range.Find.Execute Findtext:="^m", ReplaceWith:=""
         strNewFileName = Replace(docMultiple.FullName, ".docx", "_" & Right$("000" & iCurrentPage, 4) & ".docx")
         docSingle.SaveAs (strNewFileName)
         iCurrentPage = iCurrentPage + 1
         docSingle.Close
         rngPage.Collapse (0) ' wdCollapseEnd
     Loop

     WordApp.Application.ScreenUpdating = True

     WordApp.Quit

     Set docMultiple = Nothing
     Set docSingle = Nothing
     Set rngPage = Nothing
     Set WordApp = Nothing

 End Sub

Open in new window

single Page content
strText = docSingle.Range.Text

Regards
0
Rick RudolphAuthor Commented:
Thank you for an incredibly quick response. This almost worked perfectly. The only issue I see is that each document is a 2 page document .The second page of each document contains only Watermarks.

The other part of my original question which you may not have seen is below:

My next question relates to the naming of the files. Below is a snippet of code I had that was renaming some similar pdf documents. How would I search the page contents looking for the string so I can replace using the page number as the file name? So I am really asking how do I load the entire page into the FileContent string variable.

FirstCaret = InStr(1, FileContent, "^")
NextCaret = InStr((FirstCaret + 1), FileContent, "^")
NewName = Mid(FileContent, (FirstCaret + 1), (NextCaret - (FirstCaret + 1)))
0
Rgonzo1971Commented:
then try
Public Sub ParseDoc(ByVal filename As String)

     Dim WordApp As Object
     Dim docMultiple As Object
     Dim docSingle As Object
     Dim rngPage As Object
     Dim iCurrentPage As Integer
     Dim iPageCount As Integer
     Dim strNewFileName As String
     Set WordApp = CreateObject("Word.Application")

     WordApp.Application.ScreenUpdating = False
     Set docMultiple = WordApp.Documents.Open(filename)



     Set rngPage = docMultiple.Range
     iCurrentPage = 1
     iPageCount = docMultiple.Content.ComputeStatistics(2) '(WdStatistic.wdStatisticPages)

     Do Until iCurrentPage > iPageCount
         If iCurrentPage = iPageCount Or iCurrentPage = iPageCount - 1 Then
             rngPage.End = WordApp.ActiveDocument.Range.End
         Else
            'WdGoToItem.wdGoToPage  WdGoToDirection.wdGoToAbsolute
             WordApp.Selection.GoTo 1, 1, iCurrentPage + 1
             rngPage.End = WordApp.Selection.Start
         End If
         rngPage.Copy
         Set docSingle = WordApp.Documents.Add
         docSingle.Range.Paste
         docSingle.Range(docSingle.Range.End - 1, docSingle.Range.End).Delete
         docSingle.Range.Find.Execute Findtext:="^m", ReplaceWith:=""
         
         FirstCaret = InStr(1, docSingle.Range.Text, "^")
         NextCaret = InStr((FirstCaret + 1), docSingle.Range.Text, "^")
         strNewName = Mid(docSingle.Range.Text, (FirstCaret + 1), (NextCaret - (FirstCaret + 1)))

         strNewFileName = docMultiple.Path & "\" & strNewName & "_" & Right$("000" & iCurrentPage, 4) & ".docx"
         docSingle.SaveAs (strNewFileName)
         iCurrentPage = iCurrentPage + 1
         docSingle.Close
         rngPage.Collapse (0) ' wdCollapseEnd
     Loop

     WordApp.Application.ScreenUpdating = True

     WordApp.Quit

     Set docMultiple = Nothing
     Set docSingle = Nothing
     Set rngPage = Nothing
     Set WordApp = Nothing

 End Sub

Open in new window

EDITED CODE
0
Protecting & Securing Your Critical Data

Considering 93 percent of companies file for bankruptcy within 12 months of a disaster that blocked access to their data for 10 days or more, planning for the worst is just smart business. Learn how Acronis Backup integrates security at every stage

FREE DOWNLOAD
Rick RudolphAuthor Commented:
Getting a file in use message box with the new code:
FileinUse.PNG
0
Rgonzo1971Commented:
corrected code 
Public Sub ParseDoc(ByVal filename As String)

     Dim WordApp As Object
     Dim docMultiple As Object
     Dim docSingle As Object
     Dim rngPage As Object
     Dim iCurrentPage As Integer
     Dim iPageCount As Integer
     Dim strNewFileName As String
     Set WordApp = CreateObject("Word.Application")

     WordApp.Application.ScreenUpdating = False
     Set docMultiple = WordApp.Documents.Open(filename)

 '       WordApp.Visible = True

     Set rngPage = docMultiple.Range
     iCurrentPage = 1
     iPageCount = docMultiple.Content.ComputeStatistics(2) '(WdStatistic.wdStatisticPages)

     Do Until iCurrentPage > iPageCount

         If iCurrentPage = iPageCount Then
             rngPage.End = WordApp.ActiveDocument.Range.End
         Else
            'WdGoToItem.wdGoToPage  WdGoToDirection.wdGoToAbsolute
             WordApp.Selection.GoTo 1, 1, iCurrentPage + 1
             rngPage.End = WordApp.Selection.Start
         End If
         rngPage.Copy
         Set docSingle = WordApp.Documents.Add
         docSingle.Range.Paste
         docSingle.Range(docSingle.Range.End - 1, docSingle.Range.End).Delete
         docSingle.Range.Find.Execute Findtext:="^m", ReplaceWith:=""
         
         FirstCaret = InStr(1, docSingle.Range.Text, "^")
         NextCaret = InStr((FirstCaret + 1), docSingle.Range.Text, "^")
         strNewName = "aaa" ' Mid(docSingle.Range.Text, (FirstCaret + 1), (NextCaret - (FirstCaret + 1)))

         strNewFileName = docMultiple.Path & "\" & strNewName & "_" & Right$("000" & iCurrentPage, 4) & ".docx"
         docSingle.SaveAs (strNewFileName)
         iCurrentPage = iCurrentPage + 1
         docSingle.Close
         rngPage.Collapse (0) ' wdCollapseEnd
     Loop

     WordApp.Application.ScreenUpdating = True

     WordApp.Quit

     Set docMultiple = Nothing
     Set docSingle = Nothing
     Set rngPage = Nothing
     Set WordApp = Nothing

 End Sub

Open in new window

0
Rgonzo1971Commented:
Be sure to close all word  instances (Task Manager)
0
Rick RudolphAuthor Commented:
Stepping through the code, I get an error: Object doesn't support this property or method

on the following line.

strNewFileName = Replace(docMultiple.FullPath & "\" & strNewName, ".docx", "_" & Right$("000" & iCurrentPage, 4) & ".docx")
0
Rgonzo1971Commented:
try my new code 
Public Sub ParseDoc(ByVal filename As String)

     Dim WordApp As Object
     Dim docMultiple As Object
     Dim docSingle As Object
     Dim rngPage As Object
     Dim iCurrentPage As Integer
     Dim iPageCount As Integer
     Dim strNewFileName As String
     Set WordApp = CreateObject("Word.Application")

     WordApp.Application.ScreenUpdating = False
     Set docMultiple = WordApp.Documents.Open(filename)

 '       WordApp.Visible = True

     Set rngPage = docMultiple.Range
     iCurrentPage = 1
     iPageCount = docMultiple.Content.ComputeStatistics(2) '(WdStatistic.wdStatisticPages)

     Do Until iCurrentPage > iPageCount

         If iCurrentPage = iPageCount Then
             rngPage.End = WordApp.ActiveDocument.Range.End
         Else
            'WdGoToItem.wdGoToPage  WdGoToDirection.wdGoToAbsolute
             WordApp.Selection.GoTo 1, 1, iCurrentPage + 1
             rngPage.End = WordApp.Selection.Start
         End If
         rngPage.Copy
         Set docSingle = WordApp.Documents.Add
         docSingle.Range.Paste
         docSingle.Range(docSingle.Range.End - 1, docSingle.Range.End).Delete
         docSingle.Range.Find.Execute Findtext:="^m", ReplaceWith:=""
         
         FirstCaret = InStr(1, docSingle.Range.Text, "^")
         NextCaret = InStr((FirstCaret + 1), docSingle.Range.Text, "^")
         strNewName = Mid(docSingle.Range.Text, (FirstCaret + 1), (NextCaret - (FirstCaret + 1)))

         strNewFileName = docMultiple.Path & "\" & strNewName & "_" & Right$("000" & iCurrentPage, 4) & ".docx"
         docSingle.SaveAs (strNewFileName)
         iCurrentPage = iCurrentPage + 1
         docSingle.Close
         rngPage.Collapse (0) ' wdCollapseEnd
     Loop

     WordApp.Application.ScreenUpdating = True

     WordApp.Quit

     Set docMultiple = Nothing
     Set docSingle = Nothing
     Set rngPage = Nothing
     Set WordApp = Nothing

 End Sub

Open in new window

1

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Rick RudolphAuthor Commented:
Works like a charm. Thank you for all of your help.
0
Rick RudolphAuthor Commented:
Correction, I now have each page saved as a blank document. The names are correct, but we lost the contents somewhere.
0
Rgonzo1971Commented:
Could you send a dummy?
0
Rick RudolphAuthor Commented:
I think I must be the dummy. Here is what is going on........

The source document has been E-Mailed to me.
Normally when I get an E-Mailed Office attachment, when I double click on it to open it, at the top I see a message "Enable Editing"
This always works, then I do a save as and I am good to go.

On this document, when I click on the Enable Editing, everything goes blank. At the bottom of the document, it still shows the correct number of pages and shows what would appear to be a reasonable number of words at the bottom, but I see absolutely nothing.

So far, I have seen changing some trust center settings, but that does not work with the current document. I am going to have the user resend the document and I will get back to you unless you have some other ideas.
0
Rgonzo1971Commented:
without more data it's difficult to say
0
Rick RudolphAuthor Commented:
Small Update - The search string is in a Clear Font, but the rest of the document is "normal". When I "select all" and go to change the font, while I am hovering over the font selections, I do see the entire letter, but any selection I make does not seem to work.
0
Rick RudolphAuthor Commented:
Thanks again, the disappearing document issue appears to be unrelated, it has to do with the trust settings for Internet / EMail documents. I have not resolved this issue, but it is immaterial to my current project.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VBA

From novice to tech pro — start learning today.