PDFファイルをコピーしてエクセルブックにはりつけるVBA

PDFファイルをコピーしてエクセルブックにはりつけるVBAをかきました。
これをフォルダ内にあるすべてのPDFを順にエクセルブックに張り付けるやり方を
おしえていただけないでしょうか。




Sub StartAdobe()

Dim AdobeApp As String
Dim AdobeFile As String
Dim StartAdobe As Long

AdobeApp = "C:\Program Files\Adobe\Reader 11.0\Reader\AcroRd32.exe"
AdobeFile = "C:\Users\admin\test\test.pdf"

StartAdobe = Shell("" & AdobeApp & " " & AdobeFile & "", 1)

Application.OnTime Now + TimeValue("00:00:05"), "FirstStep"

End Sub

Private Sub FirstStep()

SendKeys ("^a")
SendKeys ("^c")

Application.OnTime Now + TimeValue("00:00:10"), "SecondStep"

End Sub

Private Sub SecondStep()

VBA.AppActivate Excel.Application.Caption
Windows("Book1.xlsm").Activate
Range("A1").Activate

SendKeys ("^v")

End Sub

質問者からの補足コメント

• 

  自分で１から書くことができないんです・・・
  差支えなければ、書いては頂けないでしょうか

  No.1の回答に寄せられた補足コメントです。 補足日時：2016/03/17 18:14

• 

  ありがとうございます！ただこれだと画像になってしまっていて、
  僕がとりたいのはテキストをコピーしたいんです・・・
  できないでしょうか？

  No.2の回答に寄せられた補足コメントです。 補足日時：2016/03/18 09:30

• 

  無理やり Cntl+a Cntl+c でVBAをつくることはできますか
  申し訳ないのですが、できたら作って頂けないでしょうか

  No.3の回答に寄せられた補足コメントです。 補足日時：2016/03/18 11:52

• 

  ありがとうございます。１，２個のファイルだと動いたのですが、１０個ぐらいになると
  うまく張り付けられなくなりました。。やっぱり難しいですかね・・

  No.4の回答に寄せられた補足コメントです。 補足日時：2016/03/18 18:13

• 

  これはVBA以外のプログラムだったらできたりするものなのでしょうか？

    補足日時：2016/03/19 10:54

No.5 回答者： ママチャリ 回答日時： 2016/03/19 17:11

PFDをテキストやExcelに変換するソフトがあるようなので、ググってみて下さい。

この辺を使えば、ご希望のことができるかもしれません。

No.4 回答者： ママチャリ 回答日時： 2016/03/18 17:26

無理やりです。

動作保証はできません。（私の環境では一応動きましたが･･･）
もし、低スペックのPCで実行するようであれば、Wait時間などを調整してみて下さい。
ご検討をお祈りします。

Sub sample2()
Dim MeApp As String
Dim AdobeApp As String
Dim AdobePath As String
Dim AdobeFile As String
Dim StartAdobe As Variant

MeApp = Application.Caption
AdobeApp = "C:\Program Files\Adobe\Reader 11.0\Reader\AcroRd32.exe"
AdobePath = "C:\Users\admin\test\"
AdobeFile = Dir(AdobePath & "*.pdf")

Do While AdobeFile <> ""
ThisWorkbook.Sheets("Sheet1").Range("A1").Copy
On Error GoTo ErrorHandler
StartAdobe = Shell("" & AdobeApp & " " & AdobePath & AdobeFile & "", 1)
AppActivate StartAdobe, False
On Error GoTo 0
SendKeys ("^a"), True
SendKeys ("^c"), True
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys ("%{F4}"), False

AppActivate MeApp, True
Worksheets.Add.Name = AdobeFile
ActiveSheet.Paste
Range("A1").Select

AdobeFile = Dir
Loop
Exit Sub
ErrorHandler:
Application.Wait (Now + TimeValue("0:00:03"))
Resume Next
End Sub

No.3 回答者： ママチャリ 回答日時： 2016/03/18 11:01

気持ちはわかるのですが、ちょっと無謀な気がします。

そもそもPDFはテキストではないです。仮に、mackojiさんがコピーしようとしているPDFでは、テキスト扱いでコピペができたとしても、すべてのPDFでできるとは限りません。
それから、Cntl+aで選択できるのは、表示中のページだけだったりしませんか？複数ページがある場合は、次ページ操作をしてコピーする必要がある等、難問だらけですよね？
どこまで妥協できるかにもよりますが、私なら諦めます。

No.2 回答者： ママチャリ 回答日時： 2016/03/17 21:36

SendKeysでのコピペは最終手段ですよ。

できれば避けたいところです。
そこで、こんなのはどうでしょうか。
普通の操作でいうと、新しいシートを追加して「挿入」-「オブジェクト」-「ファイルから」でPDFを張り付けるイメージです。それをDir関数でファイル名を取得しながらループしています。
検索対象のフォルダは、ThisWorkbook.Path です。

Sub sample()
Dim MyPathName
Dim MyFileName
Dim MyPDF
MyPathName = ThisWorkbook.Path & "\"
MyFileName = Dir(MyPathName & "*.pdf")
Do While MyFileName <> ""
Worksheets.Add
Set MyPDF = ActiveSheet.OLEObjects.Add(Filename:=MyPathName & MyFileName, _
Link:=False, DisplayAsIcon:=False)
MyFileName = Dir
Loop
End Sub

No.1 回答者： Hypnomatic 回答日時： 2016/03/17 18:05

Dirメソッドを使う