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