Встраивание PDF-файлов через VBA - PullRequest
Новая
       7

Встраивание PDF-файлов через VBA

0 голосов
/ 04 марта 2020

Я пытаюсь программно встраивать файлы PDF в указанные c таблицы. Когда я встраиваю с помощью переменной ClassType «Adobe.Document.2015», файл открывается без проблем, однако мне приходится вручную вставлять в путь к файлу. Когда я встраиваю, используя аргумент имени файла OLEObjects.Add, я могу сделать это программно, однако, когда пользователь открывает встроенный таким образом документ PDF, он получает сообщение об ошибке на стороне Acrobat. Это сообщение не появляется при добавлении через аргумент ClassType OLEObjects.Add. Есть ли способ использовать аргументы ClassType и Filename, чтобы мне не пришлось вручную вставлять пути к файлам?

Я в растерянности, поскольку пытался применить Application.SendKeys, но он выполняется после OLEObjects. Метод добавления разрешен, а не во время. Оцените любую помощь.

Сообщение об ошибке Adobe Acrobat 

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

1 Ответ

0 голосов
/ 04 марта 2020

Попробуйте, пожалуйста, заменить ваш код для добавления 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
...