使用VBA在Excel中打开PDF文件

Question

我无法在excel中打开pdf文件。 我写了一个宏来打开pdf文档，将所有内容复制并粘贴到excel工作簿中，但是我无法打开pdf文件。 我不断收到1004运行时错误。 任何帮助的想法将不胜感激。 到目前为止，这是我尝试过的：

Public Sub PDFCopy()

Dim o As Variant
Dim App As AcroPDDoc
Worksheets("Sheet3").Range("A2").Activate

'App.Open ("C:\NetworkDiagrams\100-Viking.pdf")
o = Shell("calc.exe", vbNormalNoFocus)
' ActiveWorkbook.FollowHyperlink ("C:\NetworkDiagram\100-Viking.pdf")

Application.Wait Now + TimeValue("00:00:05")
SendKeys ("^a")
SendKeys ("^c")
SendKeys "%{F4}"

Worksheets("Sheet3").Range("A2").Activate

SendKeys ("^v")



End Sub

这三种方法都给了我相同的运行时错误。 我没主意。

Answer 1

有两种方法可以做到这一点。

首先，您需要知道系统中安装了什么。
Acrobat与Acrobat或Adobe Reader不同。

如果只有Acrobat Reader，则为以下代码。 您使用Shell函数。
然后，要复制PDF的内容，请使用SendKeys。
有点脏代码，并非100％可靠，但我可以说它仍然有效。

Sub Get_Pdf()
    Dim XLName As String, PDFPath As String, READERPath As String
    Dim OpenPDF, sh As Worksheet

    XLName = ThisWorkbook.Name
    Set sh = Thisworkbook.Sheets(1)
    PDFPath = Application.GetOpenFilename(filefilter:="PDF file (*.pdf), *.pdf")
    If UCase(PDFPath) = "FALSE" Then Exit Sub
    '~~> Below path differs depending Adobe version and installation path
    READERPath = "C:\Program Files\Adobe\Reader 11.0\Reader\AcroRd32.exe "
    Shell READERPath & PDFPath, vbNormalFocus: DoEvents

    Application.Wait Now + TimeValue("00:00:2")

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

    SendKeys "^c"
    Application.Wait Now + TimeValue("00:00:2")

    Windows(XLName).Activate
    sh.Paste sh.Range("A1")
    SendKeys "%{F4}", True
End Sub

但是，如果您已经安装了Acrobat，请参阅此文章并检查发布在正确答案上的链接。
链接上发布了一个更新，即使只安装ADOBE reader，它也包含打开PDF的内容。

Answer 2

不知道这是否对您有用，但是会打开PDF并将其复制到A2中。 希望有人可以用一些更清洁的东西来插口。

Public Sub PDFCopy()

    'Filepath for your Adobe reader
    MyPath = "C:\Program Files\Adobe\Reader 10.0\Reader\AcroRd32.exe"
    'Filepath for your PDF to open
    MyFile = "C:\Documents\test.pdf"
    Shell MyPath & " " & MyFile, vbNormalFocus

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

    Windows("Test.xlsm").Activate
    Worksheets("Sheet2").Activate
    ActiveSheet.Range("A2").Select

    SendKeys ("^v")

End Sub