PDF converteren naar excel mbv VBA

[Ralbers]

Hallo allemaal,

Ik heb een excel probleem waar ik niet helemaal uit kom.

Ik wil een excel bestand maken wat in staat is de eerste pagina van alle pdf bestanden in een bepaalde map te kopieren naar excel

Ik ben een heel eind en het lukt mij al om meerdere pdf bestanden te openen vanuit excel

Het probleem zit hem in het laatste stukje.
Om terug te keren naar excel en daar de data te plakken

Heeft iemand tips?

Groeten Roel

Sub ophalen_pdf()

Dim pdf_map As String ''declareren map waaruit de pdf gehaald moeten worden.
pdf_map = ""
Dim st_map As String ''Map kiezen waar pdf vandaan moet komen
Dim Fol As FileDialog

''vaste gegevens opslaan
st_map = [inp_map]
Set Fol = Application.FileDialog(msoFileDialogFolderPicker)
Fol.InitialFileName = st_map

GoTo overslaan
vraag1 = MsgBox("Kies een map waar de pdf bestanden in staan opgeslagen" & vbNewLine & vbNewLine & "Standaardmap gebruiken?", vbYesNoCancel)
If vraag1 = vbCancel Then Exit Sub
If vraag1 = vbYes Then GoTo overslaan

If Fol.Show = -1 Then
    pdf_map = Foal.SelectedItems(1)
End If

Set Fol = Nothing

If pdf_map = "" Then
    MsgBox "Geen map gekozen"
    Exit Sub
End If

overslaan:
If pdf_map = "" Then pdf_map = st_map

Sheets("Input").Select
Cells(1, 1).Select
Sheets("Input").Cells.clear

Dim b As Integer
Dim myfile As String
myfile = Dir(pdf_map & "\" & "*.pdf")
b = 0

Do While myfile <> ""
    If Right(myfile, 4) <> ".pdf" Then
    Else
        b = b + 1
        ''actie
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ThisWorkbook.FollowHyperlink pdf_map & "\" & myfile, NewWindow:=True
        SendKeys "^a", True
        SendKeys "^c", True
        Application.Wait (Now + TimeValue("0:00:01"))
        
        Workbooks("PDF to xls.xlsm").Activate
        Excel.Application.Visible = True
        
        'Workbooks("PDF to xls.xlsm").Select
        Sheets("Input").Cells(1, 1).Paste
        'AppActivate "Excel.application"
        
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        myfile = Dir()
    End If
Loop
End Sub

 

[snb]

Lukt je dat met hand wel ?

Excel is niet gemaakt om PDF's te lezen (dat geldt overigens voor de meeste programma's.) of omgekeerd: PDF is niet gemaakt om door willekeurige programma's te worden gelezen.

 

[Ralbers]

Met de hand gaat dit wel
ofja kopieren en plakken
ik heb nu

SendKeys "%{F4}", True

toegevoegd
dan gaat hij wel weer terug dus het werkt wel zoals ik wil maar heb niet zoveel vertrouwen in die sendkeys methode

Eigenlijk is nu dus vooral het probleem is er een betere methode dan sendkeys?
De totale code is nu:

Dim pdf_map As String ''declareren map waaruit de pdf gehaald moeten worden.
pdf_map = ""
Dim st_map As String ''Map kiezen waar pdf vandaan moet komen
Dim Fol As FileDialog

''vaste gegevens opslaan
st_map = [inp_map]
Set Fol = Application.FileDialog(msoFileDialogFolderPicker)
Fol.InitialFileName = st_map

GoTo overslaan
vraag1 = MsgBox("Kies een map waar de pdf bestanden in staan opgeslagen" & vbNewLine & vbNewLine & "Standaardmap gebruiken?", vbYesNoCancel)
If vraag1 = vbCancel Then Exit Sub
If vraag1 = vbYes Then GoTo overslaan

If Fol.Show = -1 Then
    pdf_map = Foal.SelectedItems(1)
End If

Set Fol = Nothing

If pdf_map = "" Then
    MsgBox "Geen map gekozen"
    Exit Sub
End If

overslaan:
If pdf_map = "" Then pdf_map = st_map

Sheets("Input").Select
Cells(1, 1).Select
Sheets("Input").Cells.clear

Dim b As Integer
Dim myfile As String
myfile = Dir(pdf_map & "\" & "*.pdf")
b = 0

Do While myfile <> ""
    If Right(myfile, 4) <> ".pdf" Then
    Else
        b = b + 1
        ''actie
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ThisWorkbook.FollowHyperlink pdf_map & "\" & myfile, NewWindow:=True
        SendKeys "^a", True
        Application.Wait (Now + TimeValue("0:00:01"))
        SendKeys "^c", True
        Application.Wait (Now + TimeValue("0:00:01"))
        SendKeys "%{F4}", True
        Application.Wait (Now + TimeValue("0:00:01"))
        Sheets("Input").Cells(1, b).Select
        Sheets("Input").PasteSpecial Format:="Unicodetekst", Link:=False, _
        DisplayAsIcon:=False, NoHTMLFormatting:=True
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        myfile = Dir()
    End If
Loop

End Sub