web-dev-qa-db-ja.com

ExcelでVBAを使用してPDFを開きます

VBAを使用して、Excelブックと同じディレクトリにある適切なPDFをすべて開こうとしています。 Adobe 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
pdfexcel-vbavbaexcel
9
user2668956

PDFを開いてキーを送信するだけの場合は、これを試してみてください。

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

PDFリーダーがインストールされていると仮定しています。

30
Siddharth Rout

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

例：

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

すごい...感謝の気持ちで、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

あなたのコードをありがとう。これは私が望んでいたものとはまったく異なりますが、私に合わせて変更することができます。

1
Ian Hicks

お役に立てれば。上記の推奨に従ってシェルを使用して、フォルダーのすべてのサブフォルダーからpdfファイルを開き、コンテンツをマクロ対応ワークブックにコピーできました。以下のコードを参照してください。

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からマクロ対応ワークブックにコピーするコードを書いたので、あなたの要件に従って微調整する必要があるかもしれません

よろしく、ヘマ・カストゥリ

1
user8959244

これは、pdfをEXCELファイルにコピーするためのこのスクリプトの簡易バージョンです。


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
0
Keith Swerling