CODEWITHSUNDEEP
excelvbaacrobat
Marat_Muginov
Marat_Muginov

Reputation: 62

Embedding PDFs through VBA

I am trying to programatically embed PDF files to specific worksheets. When I embed using the ClassType variable "Adobe.Document.2015", the file opens without problems, however, I have to manually paste in the filepath. When I embed using the filename argument of OLEObjects.Add, I can do it programmatically, however, when the user opens the PDF document embedded this way, they get an error message on the Acrobat side. This message does not appear when adding through the ClassType argument of OLEObjects.Add. Is there a way to use both ClassType and Filename arguments so I don't have to manually paste the file paths?

I am at a loss as I have attempted Application.SendKeys but it is executed after the OLEObjects.Add method is resolved, not during. Appreciate any help.

Adobe Acrobat Error Message

Sub OLE_Objects_Fix()

Dim OLE As Excel.OLEObject
Dim OLEs As Excel.OLEObjects

Dim Xl As New Excel.Application
Dim Ws As Excel.Worksheet
Dim Wb As Excel.Workbook
Dim dirPath, fileName, filePath As String
Dim Rng As Excel.Range

Set Rng = Summary.Range("A1")

dirPath = "C:\Users\me\Desktop\...\Models\"
fileName = VBA.Dir(dirPath, vbNormal)

With Xl
    .Visible = True
    While fileName <> ""
        If VBA.Left(fileName, 9) = "unique identifier" Then
            Debug.Print fileName
            Set Wb = .Workbooks.Open(dirPath & fileName, False, False)
                For Each Ws In Wb.Worksheets
                    Ws.Activate
                    Set Rng = Rng.Offset(1, 0)
                    If Ws.Name = Rng.Offset(0, 1).Value Then
                        filePath = Rng.Offset(0, 3).Value
                    End If
                    For Each OLE In Ws.OLEObjects
                        OLE.Delete
                    Next OLE
                        If filePath <> "" Then
                            Debug.Print Ws.Name: Debug.Print filePath
                            Set OLEs = Ws.OLEObjects
                            Set OLE = OLEs.Add( _
                            fileName:=filePath, _
                            Link:=False, _
                            DisplayAsIcon:=False, _
                            Left:=Ws.Range("F1").Left, _
                            Top:=Ws.Range("F1").Top)
                        End If
                Next Ws
            filePath = ""
            Wb.Close (True)
        End If
        fileName = VBA.Dir
    Wend

End With

End Sub

Upvotes: 0

Views: 3650

Answers (1)

FaneDuru
FaneDuru

Reputation: 42256

Try, please, replacing your piece of code for adding OLEObject with this one and let me know if it is well open:

Set OLE = OLEs.Add( _
    fileName:=filePath, _
    Link:=False, _
    DisplayAsIcon:=True, _
    IconFileName:= _
     "C:\Windows\Installer\{AC76BA86-1033-FFFF-7760-0E0F06755100}\_SC_Acrobat.ico", _
     IconIndex:=0, _
     IconLabel:="Click to open the " & Ws.Name & " PDF file")

A second version not needing the icon path. It uses the (installed) exe path. And it also shows the associated application icon. There are two ways of doing that. Using API or extracting it directly from Registry. I will show a sample only for the first way:

Adapt your code to create the OLEObject in this way:

   exePath = exeApp(filePath)

    Set OLE = ws.OLEObjects.Add( _
            fileName:=filePath, _
            link:=False, _
            DisplayAsIcon:=True, _
            IconFileName:=exePath, _
            left:=ws.Range("F1").left, _
            top:=ws.Range("F1").top, _
            IconIndex:=0, IconLabel:="Embeded PDF (your name)")

Put the API function on top of your module (in the declarations part):

Private Declare PtrSafe Function FindExecutable Lib "shell32.dll" _
                 Alias "FindExecutableA" (ByVal lpFile As String, _
                 ByVal lpDirectory As String, ByVal lpResult As String) As Long

And copy the function able to retrieve the associated application path:

 Private Function exeApp(strFile As String) As String
       Const MAX_FILENAME_LEN = 260
       Dim i As Long, buff As String

       If strFile = "" Or Dir(strFile) = "" Then
          MsgBox "File not found!", vbCritical
          Exit Function
       End If
       'Create a buffer
       buff = String(MAX_FILENAME_LEN, 32)
       'Retrieve the name and handle of the executable
       i = FindExecutable(strFile, vbNullString, buff)
       If i > 32 Then
          exeApp = left$(buff, InStr(buff, Chr$(0)) - 1)
       Else
          MsgBox "No association found, for this file !"
       End If
    End Function

Upvotes: 1

Related Questions