VBA to place images inside a PDF next to specific text???

[ABCWork]

I am looking for a solution similar to the following thread VBA to place images inside a PDF??? but instead of adding the image at the bottom of the PDF, is there a way to find a specific text on every page and add the image next to that text? The position of the text to find is different on every page, and I'm not sure if there's a way to do this. I am stuck in the coordinates thing and I am not sure if there is a way to do that. Please let me know if you have any suggestions.

 

[John_w]

Here is the code for a simple example which searches all the pages of an input PDF for "TheText" and inserts a JPG image to the right of each matching text that it finds. Edit the code to specify the input and output PDFs, the image file and the text to find. Note that the text must be a string without spaces. You would have to modify the code to find a sequence of text strings with a space between each string (a 'phrase').

Public Sub Find_Text_in_PDF_Add_Adjacent_Image()

    Dim PDDoc As Acrobat.AcroPDDoc
    Dim JSO As Object
    Dim imageField As Object
    Dim PDFinputFile As String, PDFoutputFile As String
    Dim imageFile As String
    Dim page As Long, word As Long
    Dim quads As Variant, fieldRect(0 To 3)
    Dim wordText As String
   
    PDFinputFile = "C:\path\to\Your PDF.pdf"
    PDFoutputFile = "C:\path\to\Your PDF WITH IMAGES ADDED.pdf"
    imageFile = "C:\path\to\Your image.jpg"  'width 130 pixels, height 140 pixels
    
    Set PDDoc = New Acrobat.AcroPDDoc
    
    If PDDoc.Open(PDFinputFile) Then
        
        Set JSO = PDDoc.GetJSObject
        
        'Loop through all pages in this document
        For page = 0 To PDDoc.GetNumPages() - 1
        
            'Loop through all words on this page
            For word = 0 To JSO.getpageNumWords(page) - 1
            
                'Get nth word on this page
                wordText = JSO.getpageNthWord(page, word, True)
            
                If wordText = "TheText" Then 'a single word without spaces
                    
                    'Found the text on this page, so get coordinates of the 4 corners of its bounding rectangle -  array of 8 numbers
                    quads = JSO.getPageNthWordQuads(page, word)
        
                    'Set up 2 coordinates (4 numbers) for top-left (x1,y1) and bottom-right (x2,y2) of the bounding rectangle for the button field
                    fieldRect(0) = CLng(quads(0)(2) + 10)                       'left x1 is right-hand side of found word's bounding rectangle + 10 points gap
                    fieldRect(1) = CLng(quads(0)(1))                            'top y1 is top of found word's bounding rectangle
                    fieldRect(2) = CLng(fieldRect(0) + PixelsToPoints(130))     'right x2 is left x1 + width of the image in pixels converted to points
                    fieldRect(3) = CLng(fieldRect(1) - PixelsToPoints(140))     'bottom y2 is top y1 - height of the image in pixels converted to points
                    
                    'Add button with image to this page
                    Set imageField = JSO.addField("button" & word + 1, "button", page, fieldRect)
                    'Suppress  Run-time error 1001 - the image is successfully added, despite this error
                    On Error Resume Next
                    imageField.buttonImportIcon imageFile
                    On Error GoTo 0
                    imageField.buttonPosition = JSO.Position.iconOnly
                    imageField.readOnly = True
                    
                End If
                
            Next
            
        Next
        
        'Save the modified PDF with a new file name
        
        If PDDoc.Save(Acrobat.PDSaveFlags.PDSaveFull, PDFoutputFile) Then
            MsgBox "Successfully saved " & PDFoutputFile
        Else
            MsgBox "Cannot save the output PDF document " & PDFoutputFile, vbExclamation, "Find Text and Add Image"
        End If
        
        PDDoc.Close
    
    End If
    
    Set PDDoc = Nothing
    
End Sub

Private Function PixelsToPoints(pixels As Long, Optional DPI As Long = 96) As Double
    PixelsToPoints = pixels / DPI * 72
End Function