Excel VBA to Search for Text in PDF and Extract and Name Pages

[sachin483]

I have to extract and rename each cell in column A starting with A2 of my spreadsheet, searches for the text it finds there in the specified PDF and then extracts the page where it finds the text as a PDF, naming it with the value in the cell of the spreadsheet.

ie:- excel file A2 CODE = E00001

PDF FILE CODE =E00001

extract and save as pdf file as = E00001.pdf where it find CODE = E00001

i have foxit pdf reader

[HansV]

Do you have the full version of Adobe Acrobat (not just Adobe Reader)?

[sachin483]

i don't have full version of acrobat reader , if it is required then i will install the same

[sachin483]

I was having a small query that can it be done from word file ie:- the extract the text from word file and then save to pdf

[HansV]

If I open the PDF file in Word, the pagination is different, so I cannot determine the correct page to export. Try for yourself:

Code: Select all

Sub Test()
    Dim wrd As Object ' Word.Application
    Dim doc1 As Object ' Word.Document
    Dim doc2 As Object ' Word.Document
    Dim rng As Object ' Word.Range
    Dim f As Boolean
    Dim r As Long
    Dim m As Long
    Dim strFolder As String
    Dim strCode As String
    On Error Resume Next
    Set wrd = GetObject(Class:="Word.Application")
    If wrd Is Nothing Then
        Set wrd = CreateObject(Class:="Word.Application")
        f = True
    End If
    On Error GoTo 0
    strFolder = ThisWorkbook.Path & "\"
    Set doc1 = wrd.Documents.Open(Filename:=strFolder & "TMP.pdf", _
        AddToRecentFiles:=False, ConfirmConversions:=False)
    m = Range("A" & Rows.Count).End(xlUp).Row
    For r = 2 To m
        strCode = Range("A" & r).Value
        wrd.Selection.HomeKey Unit:=6 ' wdStory
        With wrd.Selection.Find
            .Text = strCode
            If .Execute Then
                Set rng = doc1.Bookmarks("\page").Range
                Set doc2 = wrd.Documents.Add
                rng.Copy
                doc2.Range.Paste
                doc2.ExportAsFixedFormat2 _
                    OutputFileName:=strFolder & strCode & ".pdf", _
                    ExportFormat:=17 ' wdExportFormatPDF
                doc2.Close SaveChanges:=False
            End If
        End With
    Next r
    doc1.Close SaveChanges:=False
    If f Then
        wrd.Quit SaveChanges:=False
    End If
End Sub

[sachin483]

First i am doing mail merge in word then saving the word file as pdf and then try to separate it as individual pdf file, depending on code in excel ,where i run the macro but no output,word file attached, hence i have both the file word and pdf , so how can we save them separately depending on excel code

[HansV]

That's better:

Code: Select all

Sub Test()
    Dim wrd As Object ' Word.Application
    Dim doc1 As Object ' Word.Document
    Dim doc2 As Object ' Word.Document
    Dim rng As Object ' Word.Range
    Dim f As Boolean
    Dim r As Long
    Dim m As Long
    Dim strFolder As String
    Dim strCode As String
    On Error Resume Next
    Set wrd = GetObject(Class:="Word.Application")
    If wrd Is Nothing Then
        Set wrd = CreateObject(Class:="Word.Application")
        f = True
    End If
    On Error GoTo 0
    strFolder = ThisWorkbook.Path & "\"
    Set doc1 = wrd.Documents.Open(Filename:=strFolder & "TMP.docx", _
        AddToRecentFiles:=False, ConfirmConversions:=False)
    m = Range("A" & Rows.Count).End(xlUp).Row
    For r = 2 To m
        strCode = Range("A" & r).Value
        wrd.Selection.HomeKey Unit:=6 ' wdStory
        With wrd.Selection.Find
            .Text = strCode
            If .Execute Then
                Set rng = doc1.Bookmarks("\page").Range
                Set doc2 = wrd.Documents.Add
                rng.Copy
                doc2.Range.Paste
                doc2.ExportAsFixedFormat2 _
                    OutputFileName:=strFolder & strCode & ".pdf", _
                    ExportFormat:=17 ' wdExportFormatPDF
                doc2.Close SaveChanges:=False
            End If
        End With
    Next r
    doc1.Close SaveChanges:=False
    If f Then
        wrd.Quit SaveChanges:=False
    End If
End Sub

[sachin483]

copied macro in excel but error reflecting

"Object doesn't support this property or method" at

doc2.ExportAsFixedFormat2 _
OutputFileName:=strFolder & strCode & ".pdf", _
ExportFormat:=17 ' wdExportFormatPDF


i am using Microsoft excel / word 2010 and foxit pdf reader

[HansV]

Change ExportAsFixedFormat2 to ExportAsFixedFormat. Does it work then?

[sachin483]

Thanks a lot working fine after changing,
after splitting that i want to sent the individual attachment to employee with cc and bcc with subject and body via excel through outlook as per format so can we write the procedure below

[HansV]

Try the following code. It will work best if Outlook is already running.

Code: Select all

Sub Test()
    Dim wrd As Object ' Word.Application
    Dim doc1 As Object ' Word.Document
    Dim doc2 As Object ' Word.Document
    Dim rng As Object ' Word.Range
    Dim f As Boolean
    Dim r As Long
    Dim m As Long
    Dim olk As Object ' Outlook.Application
    Dim msg As Object ' Outlook.MailItem
    Dim strFolder As String
    Dim strFile As String
    Dim strCode As String
    Dim strTo As String
    Dim strCC As String
    Dim strBCC As String
    Dim strSubject As String
    Dim strBody As String
    On Error Resume Next
    Set wrd = GetObject(Class:="Word.Application")
    If wrd Is Nothing Then
        Set wrd = CreateObject(Class:="Word.Application")
        f = True
    End If
    On Error GoTo 0
    Set olk = CreateObject(Class:="Outlook.Application")
    strFolder = ThisWorkbook.Path & "\"
    Set doc1 = wrd.Documents.Open(Filename:=strFolder & "TMP.docx", _
        AddToRecentFiles:=False, ConfirmConversions:=False)
    m = Range("A" & Rows.Count).End(xlUp).Row
    For r = 2 To m
        strCode = Range("A" & r).Value
        wrd.Selection.HomeKey Unit:=6 ' wdStory
        With wrd.Selection.Find
            .Text = strCode
            If .Execute Then
                Set rng = doc1.Bookmarks("\page").Range
                Set doc2 = wrd.Documents.Add
                rng.Copy
                doc2.Range.Paste
                strFile = strFolder & strCode & ".pdf"
                doc2.ExportAsFixedFormat _
                    OutputFileName:=strFile, _
                    ExportFormat:=17 ' wdExportFormatPDF
                doc2.Close SaveChanges:=False
                Set msg = olk.CreateItem(0) ' olMailItem
                strTo = Range("B" & r).Value
                strCC = Range("C" & r).Value
                strBCC = Range("D" & r).Value
                strSubject = Range("F" & r).Value
                strBody = Range("E" & r).Value & vbCrLf & Range("F" & r).Value
                msg.Recipients.Add(strTo).Type = 1 ' olTo
                msg.Recipients.Add(strCC).Type = 2 ' olCC
                msg.Recipients.Add(strBCC).Type = 3 ' olBCC
                msg.Attachments.Add strFile
                msg.Subject = strSubject
                msg.Body = strBody
                ' Use only one of the following to lines
                msg.Display ' To view the message in the testing phase
                msg.Send ' To send directly
            End If
        End With
    Next r
    doc1.Close SaveChanges:=False
    If f Then
        wrd.Quit SaveChanges:=False
    End If
End Sub

[sachin483]

Thanks a lot working fine ,
if there no CC or BCC email it gives error "There must be at least one name or contact group in the TO , CC or BCC box",
if there no CC or BCC email then also it should able to send

[HansV]

In your sample workbook there was a CC and BCC in every row, so I had no reason to assume that they could be mssing.
It is always better to provide a sample that is representative of the real data.

Code: Select all

Sub Test()
    Dim wrd As Object ' Word.Application
    Dim doc1 As Object ' Word.Document
    Dim doc2 As Object ' Word.Document
    Dim rng As Object ' Word.Range
    Dim f As Boolean
    Dim r As Long
    Dim m As Long
    Dim olk As Object ' Outlook.Application
    Dim msg As Object ' Outlook.MailItem
    Dim strFolder As String
    Dim strFile As String
    Dim strCode As String
    Dim strTo As String
    Dim strCC As String
    Dim strBCC As String
    Dim strSubject As String
    Dim strBody As String
    On Error Resume Next
    Set wrd = GetObject(Class:="Word.Application")
    If wrd Is Nothing Then
        Set wrd = CreateObject(Class:="Word.Application")
        f = True
    End If
    On Error GoTo 0
    Set olk = CreateObject(Class:="Outlook.Application")
    strFolder = ThisWorkbook.Path & "\"
    Set doc1 = wrd.Documents.Open(Filename:=strFolder & "TMP.docx", _
        AddToRecentFiles:=False, ConfirmConversions:=False)
    m = Range("A" & Rows.Count).End(xlUp).Row
    For r = 2 To m
        strCode = Range("A" & r).Value
        wrd.Selection.HomeKey Unit:=6 ' wdStory
        With wrd.Selection.Find
            .Text = strCode
            If .Execute Then
                Set rng = doc1.Bookmarks("\page").Range
                Set doc2 = wrd.Documents.Add
                rng.Copy
                doc2.Range.Paste
                strFile = strFolder & strCode & ".pdf"
                doc2.ExportAsFixedFormat _
                    OutputFileName:=strFile, _
                    ExportFormat:=17 ' wdExportFormatPDF
                doc2.Close SaveChanges:=False
                Set msg = olk.CreateItem(0) ' olMailItem
                strTo = Range("B" & r).Value
                strCC = Range("C" & r).Value
                strBCC = Range("D" & r).Value
                strSubject = Range("F" & r).Value
                strBody = Range("E" & r).Value & vbCrLf & Range("F" & r).Value
                msg.Recipients.Add(strTo).Type = 1 ' olTo
                If strCC <> "" Then
                    msg.Recipients.Add(strCC).Type = 2 ' olCC
                End If
                If strBCC <> "" Then
                    msg.Recipients.Add(strBCC).Type = 3 ' olBCC
                End If
                msg.Attachments.Add strFile
                msg.Subject = strSubject
                msg.Body = strBody
                ' Use only one of the following two lines
                msg.Display ' To view the message in the testing phase
                msg.Send ' To send directly
            End If
        End With
    Next r
    doc1.Close SaveChanges:=False
    If f Then
        wrd.Quit SaveChanges:=False
    End If
End Sub

[sachin483]

Thanks a lot working fine