Embed word page into excel

[samlemx18]

Hi All,
Wondering if someone can help me out. I have a word document that i want to embed into an excel sheet. I have the basic code to do this but my issue is that i want the pages to be each in a separate object. If i have a 5 page word doc, i want 5 different objects, each showing one page. Is there a way to do this? I know the object allows me to scroll through the word doc but im trying to make a template where i can import each page of a given doc.

Thanks All,
Sam

 

[MWhiteDesigns]

I've been looking to do this as well. You wouldn't be able to share the code that you already have by any chance would you?

 

[samlemx18]

Hi MWhiteDesigns,
Sorry for the delay but hope this helps! First i had to have a macro in the word document, i called mine "SplitPages":

Sub SplitPages()
    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

Then from my excel sheet i have a button that runs this code, a click event on the button:

To select file to split:

Public Sub GetScopeBtn_Click()
Dim Filter As String, Title As String
Dim FilterIndex As Integer
On Error Resume Next
GetScopeBtn.Visible = False
MsgBox ("You must select a (.doc) file")
' File filters
Filter = "MS Word Files (*.doc),*.doc,"
' Default Filter to *.*
FilterIndex = 3
' Set Dialog Caption
Title = "Select a File to Open"
' Select Start Drive & Path
ChDrive ("X")
ChDir ("X:\public\Engineering")
With Application
    ' Set File Name to selected File
    Filename = .GetOpenFilename(Filter, FilterIndex, Title)
    ' Reset Start Drive/Path
    ChDrive (Left(.DefaultFilePath, 1))
    ChDir (.DefaultFilePath)
End With
' Exit on Cancel
If Filename = False Then
    MsgBox "No file was selected."
    On Error Resume Next
    GetScopeBtn.Visible = True
    Exit Sub
End If
GetScopeBtn.SendToBack
Call Insert_WordFile_To_sheet
End Sub

Then the sub to bring in the word doc, another sub:

Sub Insert_WordFile_To_sheet()

Dim oWS As Worksheet ' Worksheet Object

Dim oOLEWd As OLEObject ' OLE Word Object
Dim WordApp As Word.Application
Dim indexOfPeriod As String
Dim indexOfFileName As String
Dim FilePathNoName As String
Dim FilePath As String
Dim pageNum As Integer
Dim WordDoc As Word.Document
Dim NewFilePath As String
Dim MyModule As Object
Dim MyModuleName As String
Dim ShapeCount As Integer
MsgBox ("Please be patient while this processes.")
MsgBox ("Click OK to errors about the converter.")
pageNum = 1

FilePath = Filename
NewFilePath = Dir(FilePath)
indexOfPeriod = InStr(1, NewFilePath, ".", vbTextCompare)
indexOfFileName = InStr(1, FilePath, NewFilePath, vbTextCompare)
FilePathNoName = Mid(FilePath, 1, indexOfFileName - 1)
NewFilePath = Mid(NewFilePath, 1, indexOfPeriod - 1)
NewFilePath = NewFilePath & "_000" & pageNum & ".doc"
NewFilePath = FilePathNoName & NewFilePath
'Check if file exists, if not split word doc
If Dir(NewFilePath) = "" Then 'File doesnt exists
    Set WordApp = CreateObject("Word.Application")
    Set WordDoc = WordApp.Documents.Open _
    (FilePath)
    WordApp.Visible = True
    MyModuleName = "Module1"
    On Error Resume Next
    Set MyModule = WordDoc.VBProject.vbComponents(MyModuleName).CodeModule
    If Err.Number <> 0 Then
        MsgBox ("If you get this error, verify you are using the correct word template with : " & MyModuleName)
        If GetScopeBtn.Enabled = False Then
        GetScopeBtn.Enabled = True
        End If
        
        'Exit Sub
    End If
    WordApp.Run "SplitPages"
    WordApp.Quit
    Set WordApp = Nothing
End If
NewFilePath = Empty
Do While pageNum > 0
NewFilePath = Dir(FilePath)
NewFilePath = Mid(NewFilePath, 1, indexOfPeriod - 1)
NewFilePath = NewFilePath & "_000" & pageNum & ".doc"
NewFilePath = FilePathNoName & NewFilePath
If Len(Dir(NewFilePath)) <= 0 Then
    Exit Do
End If
Set oWS = ActiveSheet
MsgBox (NewFilePath)
'ShapeCount = ActiveSheet.Shapes.Count
'MsgBox (ShapeCount)
Set oOLEWd = oWS.OLEObjects.Add(Filename:=NewFilePath)

oOLEWd.Name = "EmbeddedWordDoc" & pageNum

oOLEWd.Width = 600

oOLEWd.Height = 560

If pageNum = 1 Then
Dim pageOneHeight As Integer

oOLEWd.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Worksheets("Sheet1").Paste _
    Destination:=Worksheets("Sheet1").Range("A10")
Selection.Name = "Scope1"
pageOneHeight = Worksheets("Sheet1").Shapes("Scope1").Height
Worksheets("Sheet1").Shapes("Scope1").LockAspectRatio = False
Worksheets("Sheet1").Shapes("Scope1").RelativeToOriginalSize = False
Worksheets("Sheet1").Shapes("Scope1").ScaleWidth 1.52, msoTrue
Worksheets("Sheet1").Shapes("Scope1").ScaleHeight 2.45, msoTrue
Worksheets("Sheet1").Shapes("Scope1").Line.Visible = True
Worksheets("Sheet1").Shapes("Scope1").OnAction = "Scope1_Click"
End If

If pageNum = 2 Then
oOLEWd.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Worksheets("Sheet1").Paste _
    Destination:=Worksheets("Sheet1").Range("A74")
Selection.Name = "Scope2"
Worksheets("Sheet1").Shapes("Scope2").LockAspectRatio = False
Worksheets("Sheet1").Shapes("Scope2").ScaleWidth 1.47, msoTrue
Worksheets("Sheet1").Shapes("Scope2").ScaleHeight 2.64, msoTrue
Worksheets("Sheet1").Shapes("Scope2").Line.Visible = True
Worksheets("Sheet1").Shapes("Scope2").OnAction = "Scope2_Click"
End If

If pageNum = 3 Then
oOLEWd.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Worksheets("Sheet1").Paste _
    Destination:=Worksheets("Sheet1").Range("O10")
Selection.Name = "Scope3"
Worksheets("Sheet1").Shapes("Scope3").LockAspectRatio = False
Worksheets("Sheet1").Shapes("Scope3").ScaleWidth 1.59, msoTrue
Worksheets("Sheet1").Shapes("Scope3").ScaleHeight 2.14, msoTrue
Worksheets("Sheet1").Shapes("Scope3").Line.Visible = True
Worksheets("Sheet1").Shapes("Scope3").OnAction = "Scope3_Click"
End If

If pageNum = 4 Then
oOLEWd.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Worksheets("Sheet1").Paste _
    Destination:=Worksheets("Sheet1").Range("O74")
Selection.Name = "Scope4"
Worksheets("Sheet1").Shapes("Scope4").LockAspectRatio = False
Worksheets("Sheet1").Shapes("Scope4").ScaleWidth 1.57, msoTrue
Worksheets("Sheet1").Shapes("Scope4").ScaleHeight 2.35, msoTrue
Worksheets("Sheet1").Shapes("Scope4").Line.Visible = True
Worksheets("Sheet1").Shapes("Scope4").OnAction = "Scope4_Click"
End If

Range("A1").Select
oOLEWd.Delete

Set oOLEWd = Nothing
pageNum = pageNum + 1
Loop
'used to deselect word object, selects cell A1 after last word object
Range("A1").Select
Set WordApp = CreateObject("Word.Application")
WordApp.Quit SaveChanges:=wdDoNotSaveChanges
pageNum = 1
Do Until pageNum = 5
NewFilePath = ""
NewFilePath = Dir(FilePath)
NewFilePath = Mid(NewFilePath, 1, indexOfPeriod - 1)
NewFilePath = NewFilePath & "_000" & pageNum & ".doc"
NewFilePath = FilePathNoName & NewFilePath
'MsgBox (NewFilePath)
If Dir(NewFilePath) <> "" Then
    Kill NewFilePath
End If
pageNum = pageNum + 1
Loop
Set WordApp = Nothing
End Sub

Do note, i am doing a lot with my files. When my files split they have _000X, X being some number. Mine also split to only 4 pages. Any questions just let me know.

Sam