Here's the updated code. Userform1 has a Listbox1. Word documents must be open before showing the userform (ie. on load the listbox populates). On double click of listbox items, all document pages are copied to new sheets (hopefully). I've trialed it quite a bit with text and pictures and it seems to work. The only code not below is the API module code previously posted. Give it a trial and hopefully the only issues left will be placement and sizing. Dave
Userform code...
Option Explicit
Dim wdApp As Object, wdDoc As Object


Private Sub UserForm_Initialize()
Dim i As Integer, objWordDoc As Object
    ' Initialize the ListBox
    UserForm1.ListBox1.Clear


    ' Check if Word is already open
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    On Error GoTo 0


    ' If Word is open, list the open documents
    If Not wdApp Is Nothing Then
        For i = 1 To wdApp.Documents.Count
            Set objWordDoc = wdApp.Documents(i)
            UserForm1.ListBox1.AddItem objWordDoc.Name
        Next i
    Else
        UserForm1.ListBox1.AddItem "No open Word documents found."
    End If


    Set objWordDoc = Nothing
End Sub


Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim LastPara As Integer, Cnt As Integer, PageCnt As Integer
Dim ParaCnt As Integer, Myrange As Variant, PagFlag As Boolean


If UserForm1.ListBox1.List(UserForm1.ListBox1.ListIndex) = "No open Word documents found." Then
MsgBox "No open Word documents found."
Exit Sub
End If
    
'turn on pagination
If wdApp.Options.Pagination = False Then
wdApp.Options.Pagination = True
PagFlag = True
End If


Set wdDoc = wdApp.Documents(UserForm1.ListBox1.List(UserForm1.ListBox1.ListIndex))


'find last paragraph
LastPara = wdDoc.Content.Paragraphs.Count


PageCnt = 1
ParaCnt = 1




'data stored
If LastPara <> 1 Then
'loop paragraphs
For Cnt = 1 To LastPara  'LastPara paragraph(line#)
'loop multi pages
If wdDoc.Paragraphs(Cnt).Range.Information(3) > PageCnt Then
Set Myrange = wdDoc.Paragraphs(ParaCnt).Range
Myrange.SetRange Start:=Myrange.Start, _
        End:=wdDoc.Paragraphs(Cnt - 1).Range.End
Myrange.CopyAsPicture
Call MakeSheet
PageCnt = wdDoc.Paragraphs(Cnt).Range.Information(3)
ParaCnt = Cnt
End If


' 1 page or last page
If Cnt = LastPara Then
Set Myrange = wdDoc.Paragraphs(ParaCnt).Range
Myrange.SetRange Start:=Myrange.Start, _
    End:=wdDoc.Paragraphs(LastPara).Range.End
Myrange.CopyAsPicture
Call MakeSheet
End If
Next Cnt


Else 'lastpara = 1 ie. 1 para OR no data stored
Set Myrange = wdDoc.Paragraphs(1).Range
Myrange.CopyAsPicture
Call MakeSheet
End If 'lastpara <> 1


If PagFlag Then
wdApp.Options.Pagination = False
End If


' Clean up
Set wdDoc = Nothing
End Sub


Sub MakeSheet()
Dim newSheet As Worksheet, pic As Object
' Add a new worksheet in the current Excel workbook with a unique name in ascending order
Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
newSheet.Name = FindUniqueSheetName(ThisWorkbook, "Page ")


' Activate the new worksheet
newSheet.Activate


' Select cell A1 in the new worksheet
newSheet.Range("A1").Select


' Paste the clipboard contents as a picture
Set pic = newSheet.Pictures.Paste


'clear the clipboard
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
End Sub


Function FindUniqueSheetName(wb As Workbook, baseName As String) As String
    Dim newName As String
    Dim i As Integer
    i = 1
    newName = baseName & i
    Do Until WorksheetExists(wb, newName) = False
        i = i + 1
        newName = baseName & i
    Loop
    FindUniqueSheetName = newName
End Function


Function WorksheetExists(wb As Workbook, wsName As String) As Boolean
    On Error Resume Next
    WorksheetExists = Not wb.Sheets(wsName) Is Nothing
    On Error GoTo 0
End Function