在 Excel 中使用 VBA 打开 PDF

Open a PDF using VBA in Excel

提问by user2668956

I'm trying to open all appropriate PDFs found in the same directory as my Excel workbook using VBA. I've added the Adobe Acrobat xx.x Type Library reference to the project. But when I try to create the .App object I get a "Run-time error '429':" error.

我正在尝试使用 VBA 打开在与 Excel 工作簿相同的目录中找到的所有适当的 PDF。我已将 Adob​​e Acrobat xx.x 类型库引用添加到项目中。但是当我尝试创建 .App 对象时，我收到“运行时错误 '429':”错误。

What am I missing?

我错过了什么？

Here's the code;

这是代码；

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

回答by Siddharth Rout

If it's a matter of just opening PDF to send some keys to it then why not try this

如果只是打开 PDF 发送一些密钥给它，那为什么不试试这个

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

I am assuming that you have some pdf reader installed.

我假设您安装了一些 pdf 阅读器。

回答by Cyaramar

Use Shell "program file path file path you want to open".

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

Example:

例子：

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

回答by user8959244

Hope this helps. I was able to open pdf files from all subfolders of a folder and copy content to the macro enabled workbook using shell as recommended above.Please see below the code .

希望这可以帮助。我能够从一个文件夹的所有子文件夹中打开 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

I wrote the piece of code to copy from pdf and csv to the macro enabled workbook and you may need to fine tune as per your requirement

我写了一段代码从 pdf 和 csv 复制到启用宏的工作簿，您可能需要根据您的要求进行微调

Regards, Hema Kasturi

问候， 赫玛·卡斯图里

回答by Ian Hicks

WOW... In appreciation, I add a bit of code that I use to find the path to ADOBE

哇...感谢，我添加了一些代码，用于查找 ADOBE 的路径

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

and call this to find the applicable program name

并调用它来查找适用的程序名称

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

Thank you for your code, which isn't EXACTLY what I wanted, but can be adapted for me.

谢谢你的代码，这不是我想要的，但可以适合我。

回答by Keith Swerling

Here is a simplified version of this script to copy a pdf into a XL file.

这是此脚本的简化版本，用于将 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