What does word use to identify different pages within the document?

[ecalid]

I am making a sheet in excel with VBA where I can add pages by using a listbox which populates with all open documents in word. Once I have this nailed down I will be making a header type bar where I can add signature boxes and textboxes to drag and drop over the top of documents. Basically this will be a 'Docusign' copy as my company is quite frugal and prefers to be innovative.

Ideally I would have a browse function to add the pages but this didn't work that well in practice.

The code I have so far will, in an excel workbook, when pressing a commandbutton - open a userform with a listbox, contained in the listbox is all the open documents in word. Once double clicked, it will port over into a new excel sheet, the whole document as paste.special, a picture.

This works fantastic, until I am faced with a multiple sheet document, and the code will only port over the first page. Nomatter how hard I try, it doesn't seem to be able to identify the different pages. Currently the code uses .wholestory but I need this to be subjective to the document. I've tried to get VBA to identify the page breaks and then loop through until the end of the document but this just only pulled the footer etc.

Its worth noting as well that our company will refuse to use acrobat or any 3rd party software so can't use this within the coding.

If it is a single page, then .wholestory will suffice. However if it has multiple pages, I need to generate a new page in excel and then copy each page into the new sheet.

I have attached the workbook for your perusal. Sometimes you have to close all instances of word running in the system memory as the listbox picks up old documents.

If anybody could help me transfer each page from the document to a new sheet in excel then I would be massively appreciative!

[Dave]

Hi ecalid. I really don't understand why you would have multiple Word docs and/or Word applications open? Why not just list their file locations in the listbox and open the file when it's selected? Anyways, there's some code at the following link that lets you view Word document pages using a frame control on a userform....
Show Word doc in XL userform frame | MrExcel Message Board

As far as trying to transfer individual pages, you would need to set each page as a range and extract that range. Seems easy, but not so much as it's actually pretty hard to determine what constitutes a page in Word. See the "GetPageSize" function at the link which determines page size for each document....page size, or perhaps range size (due to font characteristics), is not the same for every document. I would suggest loading the document pages to a collection (with the process at the link) and then pasting the collection parts to separate XL sheets. Are you sure that if you are successful at placing all pages of the document on separate pages that you can drag and drop a signature on the document and it will actually attach it to the document? HTH. Dave

[ecalid]

Hi Dave, thanks for your reply.

That is a good question, I do have a .txt file with the file locations in which I can get the listbox to populate. I just thought by having the documents open already, this would save time rather than getting excel to open word for each document and potentially hanging and missing copying some information.

If I manually put special characters between the sheets for example %%%%%, do you think I could use this to create a manual break in which vba could look for?

With regards to the signature, I'll use a commandbutton to generate an ink picture and another to generate textboxes with pre-determined names, so that the code can pick this up, and then fill them all at once using a userform 'Signing portal'

I already have one of these set up, this is basically the next version. As adding pages has become a cumbersome process, I just need to add them at a click of a button without going in an amending all inkpicture names etc.

I'm not sure the framecontrol will work for what I need, as the image should be copied as a picture to the new excel sheet. What are your thoughts on this?

[Dave]

The frame control is just for viewing and it won't work for document signing. "manually etc.".... Yuck! My suggestion would be to use parts of the code to separate the pages, put them in a collection and then paste the items in the collection to your individual sheets. BTW, do the sheets exists or are you creating new sheets? I'll check back later as I have errands to run. Good luck. Dave

[Dave]

Hi again ecalid. Apparently, I was making this too difficult for your purposes. No need for the collection and using Word's built in page information seems suffice for your application.
Here's the userform code alterations and addition...

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)    
Dim wdApp As Object
    Dim wdDoc As Object
    
    ' Create or get a reference to the Word application
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    On Error GoTo 0
    
    ' Check if Word is open
    If wdApp Is Nothing Then
        MsgBox "Microsoft Word is not open."
    Else
        ' Get the selected Word document
        Set wdDoc = wdApp.Documents(ListBox1.ListIndex + 1)


'****************NEW STUFF
Dim LastPara As Integer, Cnt As Integer, PageCnt As Integer
Dim ParaCnt As Integer, Myrange As Variant
'find last paragraph
LastPara = wdApp.ActiveDocument.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 wdApp.ActiveDocument.Paragraphs(Cnt).Range.Information(3) > PageCnt Then
Set Myrange = wdApp.ActiveDocument.Paragraphs(ParaCnt).Range
Myrange.SetRange Start:=Myrange.Start, _
        End:=wdApp.ActiveDocument.Paragraphs(Cnt - 1).Range.End
Myrange.CopyAsPicture
Call MakeSheet
PageCnt = wdApp.ActiveDocument.Paragraphs(Cnt).Range.Information(3)
ParaCnt = Cnt
End If


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


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


'*********End OF NEW STUFF


' Activate Excel application
ThisWorkbook.Activate
End If


' Clean up
Set wdDoc = Nothing
Set wdApp = 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

I added some code to clear the clipboard as it seems that it likes to crash when you start copying and pasting pictures. So you will need to put this API code in a module...

#If VBA7 And Win64 Then
    Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Public Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
#Else
    Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Public Declare Function EmptyClipboard Lib "user32" () As Long
    Public Declare Function CloseClipboard Lib "user32" () As Long
#End If

It seem to trial OK but if the last page is not "full" it only shows the portion of the doc that is populated. If this is not OK, some extra code could fix this. HTH. Dave

[ecalid]

Wow, thank you so much Dave.

This worked perfectly in the first instance, it copied a multi page document into excel.

The issues I ran into though are:

1. If I try to do this with another document, it only copies the first document again. But what I've done to mitigate this is load each file from a browsing dialogue.
2. Sometimes the pages overlap, so for example, parts of Page 2 find themselves on Page 3 in the pasted picture.
3. The extra module code for the Win32 and 64 gave a compile error, invalid outside procedure. So i had to remove this from the code to get it to work.
4. The sizing is abit off, some pages are bigger and some are smaller. It would be ideal if they could all be the same width, between columns A & J, and then set the print area to accomodate A4 dimensions.

Is there also an alternative to export a word document to PDF, and then use the page breaks in that?

Sorry, I sound so ungreatful but I'm really not.

[Dave]

ecalid as you probably know by now, Word likes to do it's own thing. Issues...
1) Do you want to continue to load your userform listbox with open docs and then copy pages to XL from a double click on the list? A couple of things. You only need to get the instances of Word once. You can then use the Word application fetched on initialize to access the selected documents. The code provided uses wdapp.activedocument which should be replaced by Wddoc. I think I also changed this initialize code...

UserForm1.ListBox1.AddItem objWordDoc.Name

and this should be...

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

You should be able to double click the listbox to operate.
2) Page overlap is a big problem and likely related to my initial rant. Do you have any picture/shapes in the documents?
3) Did you put the code in the top of a Module? I trialed copy/pasting the posted code without difficulties.
4)Width sizes of the same document are different OR Width sizes of different documents are different OR Both? Not sure what A4 dimensions are?
Exporting to PDF and using page breaks may be possible and perhaps others may be able to offer assistance as I have no knowledge in this area. I don't think the previous code is that far away from success and will continue assistance if others don't already have a wheel made for your needs. Dave

[Chas Kenyon]

This may be off-topic or may go to the heart of your question: Word does not keep track of or use pages except at print time.

• Word Doesn't Know What a Page Is by Daiya Mitchell, MVP
• Moving/Reorganizing Pages in Microsoft Word

You are going to have to mark where you want a page to start. The easiest way is with a paragraph style that includes Page Break Before formatting.

[Dave]

Thanks Chas. That's great information. We will see about your conclusion Dave

[Dave]

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

[Dave]

Hmmmm.... Pull information from selected row via listbox (vbaexpress.com)
Apparently I have a poor memory. Dave

[Aussiebear]

Apparently I have a poor memory.

Welcome to my age Dave.

[Dave]

Oddly, I'm guessing that my memory in the future will greatly improve. Dave

[Aussiebear]

Hmmm... do you know something that the rest of us are hoping for?

Aside from that escalid has suggested that when copying a new document it only copy the first page. What causes that?

[Dave]

Aside from that escalid has suggested that when copying a new document it only copy the first page. What causes that?

ecalid did not report on the updated code.
Dave

[ecalid]

Hi Dave,

Thanks for your input on this. Didn't want to just take your code and run! I managed to get it working perfectly, this now opens a word document and populates sheets with the document pages.

I've even managed to get this to work from a .txt file containing filepaths, I also adapted this to work from a single commandbutton to open a browse function instead of using the listbox.

Depending on whether a checkbox value is true, this also generates a 'cover page' from an existing hidden page.

Without you, this wouldn't have been possible. Thank you very much.

Here is the code.

Private Sub CommandButton4_Click()
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim i As Integer
    Dim newSheet As Worksheet
    Dim pic As Object
    Dim pageCounter As Integer
    Dim pageStart As Long
    Dim pageEnd As Long
    Dim findRange As Object
    Dim filePath As String


    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select a Word Document or Text File with File Paths"
        .Filters.Add "Word Documents", "*.docx, *.doc"
        .Filters.Add "Text Files", "*.txt"
        If .Show = -1 Then
            filePath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With


    If Right(filePath, 4) = ".txt" Then
        Dim fileContents As String
        Dim fileArray() As String
        Dim fileLine As String
        Dim fileNumber As Integer


        fileNumber = FreeFile()
        Open filePath For Input As #fileNumber
        Do Until EOF(fileNumber)
            Line Input #fileNumber, fileLine
            fileLine = Trim(Replace(fileLine, """", ""))
            If fileLine <> "" Then
                fileContents = fileContents & fileLine & vbCrLf
            End If
        Loop
        Close #fileNumber




        fileArray() = Split(fileContents, vbCrLf)


        For i = LBound(fileArray) To UBound(fileArray)
            Dim docFilePath As String
            docFilePath = Trim(fileArray(i))


            If docFilePath <> "" Then
                On Error Resume Next
                Set wdApp = GetObject(, "Word.Application")
                On Error GoTo 0


                If wdApp Is Nothing Then
                    Set wdApp = CreateObject("Word.Application")
                    wdApp.Visible = True
                End If


                Set wdDoc = wdApp.Documents.Open(docFilePath)


If ThisWorkbook.Sheets("Start").CheckBox2.Value = True Then
ThisWorkbook.Sheets("Cover").Visible = xlSheetVisible
    ThisWorkbook.Sheets("Cover").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    Set newSheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) ' Reference the newly created sheet
    newSheet.Activate
    ActiveWindow.DisplayHeadings = False
    ActiveWindow.DisplayGridlines = False
    newSheet.name = LimitSheetName(CleanSheetName(GetFileNameWithoutExtension(docFilePath)), 31)
    newSheet.Visible = xlSheetVisible
    newSheet.Range("A20").Value = GetFileNameWithoutExtension(docFilePath)
    newSheet.Range("A34").Value = docFilePath
    ThisWorkbook.Sheets("Cover").Visible = xlSheetHidden
    
End If




                Dim LastPara As Integer, Cnt As Integer, PageCnt As Integer
                Dim ParaCnt As Integer, Myrange As Variant
                LastPara = wdApp.ActiveDocument.Content.Paragraphs.Count
                
                PageCnt = 1
                ParaCnt = 1


                If LastPara <> 1 Then
                    For Cnt = 1 To LastPara
                        If wdApp.ActiveDocument.Paragraphs(Cnt).Range.Information(3) > PageCnt Then
                            Set Myrange = wdApp.ActiveDocument.Paragraphs(ParaCnt).Range
                            Myrange.SetRange Start:=Myrange.Start, _
                                    End:=wdApp.ActiveDocument.Paragraphs(Cnt - 1).Range.End
                            Myrange.Copyaspicture
                            Call MakeSheet
                            PageCnt = wdApp.ActiveDocument.Paragraphs(Cnt).Range.Information(3)
                            ParaCnt = Cnt
                        End If


                        If Cnt = LastPara Then
                            Set Myrange = wdApp.ActiveDocument.Paragraphs(ParaCnt).Range
                            Myrange.SetRange Start:=Myrange.Start, _
                                End:=wdApp.ActiveDocument.Paragraphs(LastPara).Range.End
                            Myrange.Copyaspicture
                            Call MakeSheet
                        End If
                    Next Cnt
                Else
                    Set Myrange = wdApp.ActiveDocument.Paragraphs(1).Range
                    Myrange.Copyaspicture
                    Call MakeSheet
                End If


                wdDoc.Close
            End If
        Next i
    Else


        On Error Resume Next
        Set wdApp = GetObject(, "Word.Application")
        On Error GoTo 0


        If wdApp Is Nothing Then
            Set wdApp = CreateObject("Word.Application")
            wdApp.Visible = True
        End If


        Set wdDoc = wdApp.Documents.Open(filePath)


    If ThisWorkbook.Sheets("Start").CheckBox2.Value = True Then
    ThisWorkbook.Sheets("Cover").Visible = xlSheetVisible
    ThisWorkbook.Sheets("Cover").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    Set newSheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    newSheet.Activate
    ActiveWindow.DisplayHeadings = False
    ActiveWindow.DisplayGridlines = False
    newSheet.name = LimitSheetName(CleanSheetName(GetFileNameWithoutExtension(filePath)), 31)
    newSheet.Visible = xlSheetVisible
    newSheet.Range("A20").Value = GetFileNameWithoutExtension(filePath)
    newSheet.Range("A34").Value = filePath
    ThisWorkbook.Sheets("Cover").Visible = xlSheetHidden
    End If




        LastPara = wdApp.ActiveDocument.Content.Paragraphs.Count
                
        PageCnt = 1
        ParaCnt = 1


        If LastPara <> 1 Then
            For Cnt = 1 To LastPara
                If wdApp.ActiveDocument.Paragraphs(Cnt).Range.Information(3) > PageCnt Then
                    Set Myrange = wdApp.ActiveDocument.Paragraphs(ParaCnt).Range
                    Myrange.SetRange Start:=Myrange.Start, _
                            End:=wdApp.ActiveDocument.Paragraphs(Cnt - 1).Range.End
                    Myrange.Copyaspicture
                    Call MakeSheet
                    PageCnt = wdApp.ActiveDocument.Paragraphs(Cnt).Range.Information(3)
                    ParaCnt = Cnt
                End If


                If Cnt = LastPara Then
                    Set Myrange = wdApp.ActiveDocument.Paragraphs(ParaCnt).Range
                    Myrange.SetRange Start:=Myrange.Start, _
                        End:=wdApp.ActiveDocument.Paragraphs(LastPara).Range.End
                    Myrange.Copyaspicture
                    Call MakeSheet
                End If
            Next Cnt
        Else
            Set Myrange = wdApp.ActiveDocument.Paragraphs(1).Range
            Myrange.Copyaspicture
            Call MakeSheet
        End If


        wdDoc.Close
    End If


    ThisWorkbook.Activate


    Set wdDoc = Nothing
    Set wdApp = Nothing
End Sub


Sub MakeSheet()
    Dim newSheet As Worksheet
    Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    newSheet.name = FindUniqueSheetName(ThisWorkbook, "Page ")


    newSheet.Activate


    ActiveWindow.DisplayHeadings = False
    ActiveWindow.DisplayGridlines = False


    With newSheet.PageSetup
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With


    newSheet.Range("B3").Select


    Application.CutCopyMode = False
    ActiveSheet.PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False
End Sub








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
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 LimitSheetName(ByVal name As String, ByVal maxLength As Integer) As String
    If Len(name) > maxLength Then
        LimitSheetName = Left(name, maxLength)
    Else
        LimitSheetName = name
        End If
End Function




Function GetFileNameWithoutExtension(ByVal filePath As String) As String
    Dim pos As Integer
    pos = InStrRev(filePath, "\")
    If pos > 0 Then
        filePath = Mid(filePath, pos + 1)
    End If
    
    pos = InStrRev(filePath, ".")
    
    If pos > 0 Then
        GetFileNameWithoutExtension = Left(filePath, pos - 1)
    Else
        GetFileNameWithoutExtension = filePath
    End If
End Function


Function CleanSheetName(ByVal name As String) As String
    CleanSheetName = Replace(name, ".", "_")
End Function

[Dave]

ecalid thank you for posting your updated code. I see that you have resolved the placement and sizing issues as well. The clipboard code posted does work and if you run into XL crashing problems, you may want to consider it's re-inclusion. You are welcome and again thanks for posting your outcome. Dave

[gmaxey]

ecalid
I pasted your code in the workbook you originally posted and it appears that there are more control references in the code now than there are controls in that version. Would you be willing to post an updated file?