在 Excel 中使用 VBA 打開 PDF

Question

我正在嘗試使用 VBA 打開在與 Excel 工作簿相同的目錄中找到的所有適當的 PDF。 我已將 Adob​​e Acrobat xx.x 類型庫引用添加到項目中。 但是當我嘗試創建 .App 對象時，我收到“運行時錯誤 '429'：”錯誤。

我錯過了什么？

這是代碼；

Sub ImportNames()
Dim BlrInfoFileList() As String, NbrOfFiles As Integer, FileNameStr As String
Dim X As Integer, pdfApp As AcroApp, pdfDoc As AcroAVDoc


'Find all of the Contact Information PDFs
FileNameStr = Dir(ThisWorkbook.Path & "\*Contact Information.pdf")
NbrOfFiles = 0
Do Until FileNameStr = ""
    NbrOfFiles = NbrOfFiles + 1
    ReDim Preserve BlrInfoFileList(NbrOfFiles)
    BlrInfoFileList(NbrOfFiles) = FileNameStr
    FileNameStr = Dir()
Loop

For X = 1 To NbrOfFiles
    FileNameStr = ThisWorkbook.Path & "\" & BlrInfoFileList(X)
    Set pdfApp = CreateObject("AcroExch.App")
    pdfApp.Hide

    Set pdfDoc = CreateObject("AcroExch.AVDoc")
    pdfDoc.Open FileNameStr, vbNormalFocus

    SendKeys ("^a")
    SendKeys ("^c")
    SendKeys "%{F4}"

    ThisWorkbook.Sheets("Raw Data").Range("A1").Select
    SendKeys ("^v")
    Set pdfApp = Nothing
    Set pdfDoc = Nothing

    'Process Raw Data and Clear the sheet for the next PDF Document
Next X
End Sub

Answer 1

如果只是打開 PDF 發送一些密鑰給它，那為什么不試試這個

Sub Sample()
    ActiveWorkbook.FollowHyperlink "C:\MyFile.pdf"
End Sub

我假設您安裝了一些 pdf 閱讀器。

Answer 2

使用Shell "program file path file path you want to open" 。

示例：

Shell "c:\windows\system32\mspaint.exe c:users\admin\x.jpg"

Answer 3

希望這會有所幫助。 我能夠從一個文件夾的所有子文件夾中打開 pdf 文件，並按照上面的建議使用 shell 將內容復制到啟用宏的工作簿。請參閱下面的代碼。

Sub ConsolidateWorkbooksLTD()
Dim adobeReaderPath As String
Dim pathAndFileName As String
Dim shellPathName As String
Dim fso, subFldr, subFlodr
Dim FolderPath
Dim Filename As String
Dim Sheet As Worksheet
Dim ws As Worksheet
Dim HK As String
Dim s As String
Dim J As String
Dim diaFolder As FileDialog
Dim mFolder As String
Dim Basebk As Workbook
Dim Actbk As Workbook

Application.ScreenUpdating = False

Set Basebk = ThisWorkbook

' Open the file dialog
Set diaFolder = Application.FileDialog(msoFileDialogFolderPicker)
diaFolder.AllowMultiSelect = False
diaFolder.Show
MsgBox diaFolder.SelectedItems(1) & "\"
mFolder = diaFolder.SelectedItems(1) & "\"
Set diaFolder = Nothing
Set fso = CreateObject("Scripting.FileSystemObject")
Set FolderPath = fso.GetFolder(mFolder)
For Each subFldr In FolderPath.SubFolders
subFlodr = subFldr & "\"
Filename = Dir(subFldr & "\*.csv*")
Do While Len(Filename) > 0
J = Filename
J = Left(J, Len(J) - 4) & ".pdf"
   Workbooks.Open Filename:=subFldr & "\" & Filename, ReadOnly:=True
   For Each Sheet In ActiveWorkbook.Sheets
   Set Actbk = ActiveWorkbook
   s = ActiveWorkbook.Name
   HK = Left(s, Len(s) - 4)
   If InStrRev(HK, "_S") <> 0 Then
   HK = Right(HK, Len(HK) - InStrRev(HK, "_S"))
   Else
   HK = Right(HK, Len(HK) - InStrRev(HK, "_L"))
   End If
   Sheet.Copy After:=ThisWorkbook.Sheets(1)
   ActiveSheet.Name = HK

   ' Open pdf file to copy SIC Decsription
   pathAndFileName = subFlodr & J
   adobeReaderPath = "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe"
   shellPathName = adobeReaderPath & " """ & pathAndFileName & """"
   Call Shell( _
    pathname:=shellPathName, _
    windowstyle:=vbNormalFocus)
    Application.Wait Now + TimeValue("0:00:2")

    SendKeys "%vpc"
    SendKeys "^a", True
    Application.Wait Now + TimeValue("00:00:2")

    ' send key to copy
     SendKeys "^c"
    ' wait 2 secs
     Application.Wait Now + TimeValue("00:00:2")
      ' activate this workook and paste the data
        ThisWorkbook.Activate
        Set ws = ThisWorkbook.Sheets(HK)
        Range("O1:O5").Select
        ws.Paste

        Application.Wait Now + TimeValue("00:00:3")
        Application.CutCopyMode = False
        Application.Wait Now + TimeValue("00:00:3")
       Call Shell("TaskKill /F /IM AcroRd32.exe", vbHide)
       ' send key to close pdf file
        SendKeys "^q"
       Application.Wait Now + TimeValue("00:00:3")
 Next Sheet
 Workbooks(Filename).Close SaveAs = True
 Filename = Dir()
Loop
Next
Application.ScreenUpdating = True
End Sub

我寫了一段代碼從 pdf 和 csv 復制到啟用宏的工作簿，您可能需要根據您的要求進行微調

問候， 赫瑪·卡斯圖里

Answer 4

哇...感謝，我添加了一些代碼，用於查找 ADOBE 的路徑

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

並調用它來查找適用的程序名稱

Public Function GetFileAssociation(ByVal sFilepath As String) As String
Dim i               As Long
Dim E               As String
    GetFileAssociation = "File not found!"
    If Dir(sFilepath) = vbNullString Or sFilepath = vbNullString Then Exit Function
    GetFileAssociation = "No association found!"
    E = String(260, Chr(0))
    i = FindExecutable(sFilepath, vbNullString, E)
    If i > 32 Then GetFileAssociation = Left(E, InStr(E, Chr(0)) - 1)
End Function

謝謝你的代碼，這不是我想要的，但可以適合我。

Answer 5

這是此腳本的簡化版本，用於將 pdf 復制到 XL 文件中。

Sub CopyOnePDFtoExcel()

    Dim ws As Worksheet
    Dim PDF_path As String

    PDF_path = "C:\Users\...\Documents\This-File.pdf"


    'open the pdf file
    ActiveWorkbook.FollowHyperlink PDF_path

    SendKeys "^a", True
    SendKeys "^c"

    Call Shell("TaskKill /F /IM AcroRd32.exe", vbHide)

    Application.ScreenUpdating = False

    Set ws = ThisWorkbook.Sheets("Sheet1")

    ws.Activate
    ws.Range("A1").ClearContents
    ws.Range("A1").Select
    ws.Paste

    Application.ScreenUpdating = True

End Sub