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

Rick Rudolph
Rick Rudolph used Ask the Experts™
on
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)))
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Top Expert 2016

Commented:
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

Author

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)))
Top Expert 2016

Commented:
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
Ensure you’re charging the right price for your IT

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!

Author

Commented:
Getting a file in use message box with the new code:
FileinUse.PNG
Top Expert 2016

Commented:
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

Top Expert 2016

Commented:
Be sure to close all word  instances (Task Manager)

Author

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")
Top Expert 2016
Commented:
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

Author

Commented:
Works like a charm. Thank you for all of your help.

Author

Commented:
Correction, I now have each page saved as a blank document. The names are correct, but we lost the contents somewhere.
Top Expert 2016

Commented:
Could you send a dummy?

Author

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.
Top Expert 2016

Commented:
without more data it's difficult to say

Author

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.

Author

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.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial