HomePricingCommunityTeamsAboutStart Free TrialLog in
Avatar of Rick Rudolph
Rick Rudolph
Flag for United States of America asked on

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)))
VBAMicrosoft OfficeMicrosoft Applications
Avatar of undefined
Last Comment
Rick Rudolph
8/22/2022 - Mon
Rgonzo1971
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
Rick Rudolph
ASKER
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)))
Rgonzo1971
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
I started with Experts Exchange in 2004 and it's been a mainstay of my professional computing life since. It helped me launch a career as a programmer / Oracle data analyst
William Peck
Rick Rudolph
ASKER
Getting a file in use message box with the new code:
FileinUse.PNG
Rgonzo1971
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

Rgonzo1971
Be sure to close all word  instances (Task Manager)
Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.
Rick Rudolph
ASKER
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")
ASKER CERTIFIED SOLUTION
Rgonzo1971
Log in or sign up to see answer
Become an EE member today7-DAY FREE TRIAL
Members can start a 7-Day Free trial then enjoy unlimited access to the platform
Sign up - Free for 7 days
or
Learn why we charge membership fees
We get it - no one likes a content blocker. Take one extra minute and find out why we block content.
Not exactly the question you had in mind?
Sign up for an EE membership and get your own personalized solution. With an EE membership, you can ask unlimited troubleshooting, research, or opinion questions.
ask a question
Rick Rudolph
ASKER
Works like a charm. Thank you for all of your help.
Rick Rudolph
ASKER
Correction, I now have each page saved as a blank document. The names are correct, but we lost the contents somewhere.
Experts Exchange has (a) saved my job multiple times, (b) saved me hours, days, and even weeks of work, and often (c) makes me look like a superhero! This place is MAGIC!
Walt Forbes
Rgonzo1971
Could you send a dummy?
Rick Rudolph
ASKER
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.
Rgonzo1971
without more data it's difficult to say
Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.
Rick Rudolph
ASKER
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.
Rick Rudolph
ASKER
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.
Plans and Pricing
Resources
Product
Podcasts
Careers
Contact Us
Teams
Certified Expert Program
Credly Partnership
Udemy Partnership
Privacy Policy
Terms of Use

© 1996-2023 Experts Exchange, LLC. All rights reserved. Covered by US Patent