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!
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.W
Dim docMultiple As Microsoft.Office.Interop.W
Dim docSingle As Microsoft.Office.Interop.W
Dim rngPage As Microsoft.Office.Interop.W
Dim iCurrentPage As Integer
Dim iPageCount As Integer
Dim strNewFileName As String
WordApp.Application.Screen
docMultiple = WordApp.Documents.Open(fil
rngPage = docMultiple.Range
iCurrentPage = 1
iPageCount = docMultiple.Content.Comput
Do Until iCurrentPage > iPageCount
If iCurrentPage = iPageCount Or iCurrentPage = iPageCount - 1 Then
rngPage.End = WordApp.ActiveDocument.Ran
Else
WordApp.Selection.GoTo(WdG
rngPage.End = WordApp.Selection.Start
End If
rngPage.Copy()
docSingle = WordApp.Documents.Add
docSingle.range.Paste()
docSingle.range.Find.Execu
strNewFileName = Replace(docMultiple.FullNa
docSingle.SaveAs (strNewFileName)
iCurrentPage = iCurrentPage + 1
docSingle.Close()
rngPage.Collapse (WdCollapseDirection.wdCol
Loop
WordApp.Application.Screen
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)))
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.W
Dim docMultiple As Microsoft.Office.Interop.W
Dim docSingle As Microsoft.Office.Interop.W
Dim rngPage As Microsoft.Office.Interop.W
Dim iCurrentPage As Integer
Dim iPageCount As Integer
Dim strNewFileName As String
WordApp.Application.Screen
docMultiple = WordApp.Documents.Open(fil
rngPage = docMultiple.Range
iCurrentPage = 1
iPageCount = docMultiple.Content.Comput
Do Until iCurrentPage > iPageCount
If iCurrentPage = iPageCount Or iCurrentPage = iPageCount - 1 Then
rngPage.End = WordApp.ActiveDocument.Ran
Else
WordApp.Selection.GoTo(WdG
rngPage.End = WordApp.Selection.Start
End If
rngPage.Copy()
docSingle = WordApp.Documents.Add
docSingle.range.Paste()
docSingle.range.Find.Execu
strNewFileName = Replace(docMultiple.FullNa
docSingle.SaveAs (strNewFileName)
iCurrentPage = iCurrentPage + 1
docSingle.Close()
rngPage.Collapse (WdCollapseDirection.wdCol
Loop
WordApp.Application.Screen
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)))
Do more with
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Hi,
pls try
strText = docSingle.Range.Text
Regards
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
strText = docSingle.Range.Text
Regards
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)))
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)))
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
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
Stepping through the code, I get an error: Object doesn't support this property or method
on the following line.
strNewFileName = Replace(docMultiple.FullPa
on the following line.
strNewFileName = Replace(docMultiple.FullPa
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
Correction, I now have each page saved as a blank document. The names are correct, but we lost the contents somewhere.
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.
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.
Premium Content
You need an Expert Office subscription to comment.Start Free Trial