通过 VBA 嵌入 PDF

Question

我正在尝试以编程方式将 PDF 文件嵌入到特定的工作表中。当我使用 ClassType 变量“Adobe.Document.2015”嵌入时，文件打开没有问题，但是，我必须手动粘贴到文件路径中。当我使用 OLEObjects.Add 的文件名参数进行嵌入时，我可以以编程方式执行此操作，但是，当用户打开以这种方式嵌入的 PDF 文档时，他们会在 Acrobat 端收到一条错误消息。通过 OLEObjects.Add 的 ClassType 参数添加时不会出现此消息。有没有办法同时使用 ClassType 和 Filename 参数，这样我就不必手动粘贴文件路径？

当我尝试 Application.SendKeys 时，我不知所措，但它是在 OLEObjects.Add 方法解决后执行的，而不是在解决期间执行。感谢任何帮助。

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

Answer 1

请尝试，用这个替换你添加 OLEObject 的代码，如果它打开的话，请告诉我：

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")

第二个版本不需要图标路径。它使用（安装的）exe 路径。 它还显示相关的应用程序图标。有两种方法可以做到这一点。使用 API 或直接从注册表中提取。我将仅展示第一种方式的示例：

调整您的代码以通过这种方式创建 OLEObject：

   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)")

将 API 函数放在模块顶部（在声明部分）：

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

并复制能够检索关联应用程序路径的函数：

 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