Sub BatchRenameCS()
Dim objApp As Object
Dim objPDDoc As Object
Dim objjso As Object
Dim newPDF As Acrobat.CAcroPDDoc
Dim lastrow2 As Long
Dim strFileName As String
Dim Folder As String
Dim Page As Long
Dim Cell As Long
Dim PDFCharacterCount() As Long
Dim CharacterCount As Long
Dim i As Integer
Dim c As Integer
Dim x As Integer
Dim strSource As String
Dim strResult As String
Dim PDFCharacters As String
Dim PDFCharacters2 As String
Dim PDFPasteData() As String
Dim PasteDataPage As Integer
Dim LastRow As Long
Dim NewName As String
Dim NewNamePageNum As Integer
Dim Check()
Sheets("Sheet1").Range("C:D").ClearContents
strFileName = selectFile()
Folder = GetFolder()
'create array with pdf word count
Set objApp = CreateObject("AcroExch.App")
Set objPDDoc = CreateObject("AcroExch.PDDoc")
'AD.1 open file, if =false file is damage
If objPDDoc.Open(strFileName) Then
Set objjso = objPDDoc.GetJSObject
ReDim PDFCharacterCount(1 To objPDDoc.GetNumPages) As Long
For Page = 1 To objPDDoc.GetNumPages
PDFCharacters = ""
PDFCharacters2 = ""
For c = 0 To objjso.GetPageNumWords(Page - 1)
PDFCharacters = PDFCharacters & objjso.getPageNthWord(Page - 1, c)
Next c
For i = 1 To Len(PDFCharacters)
Select Case Asc(Mid(PDFCharacters, i, 1))
Case 48 To 57, 65 To 90, 97 To 122:
PDFCharacters2 = PDFCharacters2 & (Mid(PDFCharacters, i, 1))
Case Else
PDFCharacters2 = PDFCharacters2 & ""
End Select
Next
PDFCharacterCount(Page) = Len(PDFCharacters2)
Next Page
lastrow2 = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
Page = 1
ReDim PDFPasteData(1 To objPDDoc.GetNumPages) As String
For Cell = 1 To lastrow2
strResult = ""
strSource = Sheets("Sheet2").Cells(Cell, 1).Text
PDFPasteData(Page) = PDFPasteData(Page) & " " & strSource
For i = 1 To Len(strSource)
Select Case Asc(Mid(strSource, i, 1))
Case 48 To 57, 65 To 90, 97 To 122:
strResult = strResult & (Mid(strSource, i, 1))
Case Else
strResult = strResult & ""
End Select
Next
CharacterCount = CharacterCount + Len(strResult)
If CharacterCount = PDFCharacterCount(Page) Then
CharacterCount = 0
Page = Page + 1
End If
Next Cell
ReDim Check(2, objPDDoc.GetNumPages)
LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For Each LookUpCell In Worksheets("Sheet1").Range("A2:A" & LastRow)
For PasteDataPage = 1 To objPDDoc.GetNumPages
If InStr(PDFPasteData(PasteDataPage), LookUpCell.Value) Then
Check(1, PasteDataPage) = Check(1, PasteDataPage) + 1
Check(2, PasteDataPage) = Check(2, PasteDataPage) & LookUpCell.Offset(0, 1).Value & Chr(10)
If FileExist(Folder & "" & LookUpCell.Offset(0, 1) & ".pdf") Then
Set newPDF = CreateObject("AcroExch.pdDoc")
NewName = Folder & "" & LookUpCell.Offset(0, 1) & ".pdf"
newPDF.Open (NewName)
newPDF.InsertPages newPDF.GetNumPages - 1, objPDDoc, PasteDataPage - 1, 1, 0
newPDF.Save 1, NewName
newPDF.Close
Set newPDF = Nothing
Else
Set newPDF = CreateObject("AcroExch.PDDoc")
newPDF.Create
NewName = Folder & "" & LookUpCell.Offset(0, 1) & ".pdf"
newPDF.InsertPages -1, objPDDoc, PasteDataPage - 1, 1, 0
newPDF.Save 1, NewName
newPDF.Close
Set newPDF = Nothing
End If
End If
Next PasteDataPage
Next LookUpCell
x = 1
For PasteDataPage = 1 To objPDDoc.GetNumPages
If Check(1, PasteDataPage) <> 1 Then
Sheets("Sheet1").Cells(x, 3) = PasteDataPage
Sheets("Sheet1").Cells(x, 4) = Check(2, PasteDataPage)
x = x + 1
End If
Next PasteDataPage
End If
MsgBox "Done"
End Sub
Function FileExist(path As String) As Boolean
If Dir(path) <> vbNullString Then FileExist = True
End Function
Function selectFile()
Dim fd As FileDialog, fileName As String
On Error GoTo ErrorHandler
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = False
If fd.Show = True Then
If fd.SelectedItems(1) <> vbNullString Then
fileName = fd.SelectedItems(1)
End If
Else
'Exit code if no file is selected
End
End If
'Return Selected FileName
selectFile = fileName
Set fd = Nothing
Exit Function
ErrorHandler:
Set fd = Nothing
MsgBox "Error " & Err & ": " & Error(Err)
End Function
Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select the Folder where you want you new PDFs to go"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
For p = 64 To 64 '0 To AcroPDDoc.GetNumPages - 1
PageText = " "
For i = 0 To TextSelect.GetNumText - 1
Debug.Print i; ">" & Replace(TextSelect.GetText(i), vbCrLf, "CRLF") & "<"
If InStr(TextSelect.GetText(i), "A3.1") Then Stop
PageText = PageText & Replace(TextSelect.GetText(i), vbCrLf, " ")
Next
PageText = PageText & " "
Debug.Print PageText
StopPublic Sub Search_Strings_in_PDF_Pages()
Dim AcroApp As CAcroApp
Dim AcroPDDoc As CAcroPDDoc
Dim AcroHiliteList As CAcroHiliteList
Dim TextSelect As CAcroPDTextSelect
Dim Page As CAcroPDPage
Dim PageContent As CAcroHiliteList
Dim PDFfile As String
Dim searchStringCells As Range, searchString As Range
Dim p As Long, i As Long
Dim PageText As String
Dim foundPageNumbers As String
'Search selected cells
'Set searchStringCells = Selection
'Or column A cells
With ActiveSheet
Set searchStringCells = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With
PDFfile = Application.GetOpenFilename("PDF Files (*.pdf), *.pdf", Title:="Select the PDF file to search")
If PDFfile = "False" Then Exit Sub
Set AcroApp = CreateObject("AcroExch.App")
Set AcroPDDoc = CreateObject("AcroExch.PDDoc")
'Open the PDF
If Not AcroPDDoc.Open(PDFfile) Then
MsgBox PDFfile & " couldn't be opened - macro exiting"
Exit Sub
End If
searchStringCells.Offset(, 1).Cells.Clear
'Read each page
For p = 0 To AcroPDDoc.GetNumPages - 1
Set Page = AcroPDDoc.AcquirePage(p)
Set PageContent = CreateObject("AcroExch.HiliteList")
'Get up to 9,999 words from this page
If PageContent.Add(0, 9999) Then
Set TextSelect = Page.CreatePageHilite(PageContent)
If Not TextSelect Is Nothing Then
'Extract all page content into a text string with each word delimited by ' '
PageText = " "
For i = 0 To TextSelect.GetNumText - 1
'Debug.Print i; ">" & Replace(TextSelect.GetText(i), vbCrLf, "CRLF") & "<"
'If InStr(TextSelect.GetText(i), "A3.1") Then Stop
PageText = PageText & Replace(TextSelect.GetText(i), vbCrLf, " ")
Next
PageText = PageText & " "
'Debug.Print PageText
'Stop
'Search for each cell string in this page
For Each searchString In searchStringCells
foundPageNumbers = searchString.Offset(, 1).Value
If InStr(1, PageText, " " & searchString.Value & " ", vbTextCompare) > 0 Then
If foundPageNumbers = "" Then
foundPageNumbers = p + 1
Else
foundPageNumbers = foundPageNumbers & ", " & p + 1
End If
searchString.Offset(, 1).Value = foundPageNumbers
End If
Next
End If
Else
MsgBox "PageContent.Add error on page " & p + 1 & " - page not searched"
End If
Next
AcroPDDoc.Close
AcroApp.Exit
With ActiveSheet
.Columns("B:B").NumberFormat = "@" 'Text format
End With
MsgBox "Finished"
End Sub| Test Checklister.xlsm | ||||
|---|---|---|---|---|
| A | B | |||
| 1 | Annex Ref | Page Numbers | ||
| 2 | A3.1.1 | 65 | ||
| 3 | A3.1.2 | 65 | ||
| 4 | A3.1.3(a) | 65 | ||
| 5 | A3.1.3(b) | 4, 11, 65 | ||
| 6 | A3.1.3(c) | 65 | ||
| 7 | A3.1.3(d) | 65 | ||
| 8 | A3.1.4 | 37, 65 | ||
| 9 | A3.1.5 | 65 | ||
| 10 | A3.2.1 | 4, 11, 65 | ||
| 11 | A3.3.1 | 14, 65 | ||
| 12 | A3.4.1 | 65 | ||
| 13 | A3.4.2 | 65 | ||
| 14 | A3.5.1 | 65 | ||
| 15 | A3.5.1(a) | 37, 62, 65 | ||
| 16 | A3.5.1(b) | 65 | ||
| 17 | A3.5.1(b)(i) | 65 | ||
| 18 | A3.5.1(b)(ii) | 65 | ||
| 19 | A3.5.1(b)(iii) | 65 | ||
| 20 | A3.5.2 | 65 | ||
Sheet1 | ||||
You could use similar debugging code that I used in post #21, but withthe script will pick up 16 instances of A3.5.1(a) but miss a single one and misses A3.3.1 in the one area in which it appears on pg 14 of the real document. Would you be able to help me add a block that will print the output of the page inspections from specified pages so that I can see what it is viewing those strings to be?
For p = 13 To 13 for page 14.
