Error msg with VBA opening a PDF

[rex759]

Hello,

I got the code from this site and it seems to error on

vStartAdobe = Shell("" & sAdobeApp & " " & sPath & sAdobeFile & "", 1)

I receive two error messages,

1. There was an error opening this document. Access denied.
2. There was an error opening this document. Document cannot be found.

I am wondering if it’s a security issue with accessing the program or what.

Any ideas?

Option Explicit

Sub LoopThroughFiles()
    Dim strFile As String, strPath As String
    Dim colFiles As New Collection
    Dim i As Integer
    Dim rLog As Range, rOut As Range
    Dim wsLog As Worksheet, wsOutp As Worksheet
    
    strPath = "C:\Users\xxxxxx\OneDrive\Desktop\new\"
    strFile = Dir(strPath)
    ' Make a log sheet
    On Error Resume Next
    Set wsLog = Sheets("PdfProcessLog")
    On Error GoTo 0
    If wsLog Is Nothing Then
        Set wsLog = ThisWorkbook.Sheets.Add(before:=Sheets(1))
        wsLog.Name = "PdfProcessLog"
    End If
    Set rLog = wsLog.Range("A1")
    rLog.CurrentRegion.ClearContents
    rLog.Value = "PDF files copied to sheets"
    
    ' load all the files in a Collection
    While strFile <> ""
        If StrComp(Right(strFile, 3), "pdf", vbTextCompare) = 0 Then
            colFiles.Add strFile
        End If
        strFile = Dir
    Wend
    
    Application.DisplayAlerts = False
    
    'Loop through the pdf's stored in the collection
    For i = 1 To colFiles.Count
        'List filenames in Column A of the log sheet
        rLog.Offset(i, 0).Value = colFiles(i)
        strFile = Left(colFiles(i), Len(colFiles(i)) - 4)
        
        ' Delete sheet with filename if exists
        On Error Resume Next
        Set wsOutp = Sheets(strFile)
        On Error GoTo 0
        If Not wsOutp Is Nothing Then
            wsOutp.Delete
        End If
        ' (Re)Create the worksheet, give it the file name
        Set wsOutp = ThisWorkbook.Sheets.Add(after:=wsLog)
        wsOutp.Name = Left(strFile, 25)
        
        ' Now open the file, and copy contents
        OpenClosePDF colFiles(i), strPath
        CopyStep wsOutp
    Next i
    
    Application.DisplayAlerts = True
End Sub
Sub OpenClosePDF(ByVal sAdobeFile As String, ByVal sPath As String)
    Dim sAdobeApp As String
    Dim vStartAdobe As Variant
    sAdobeApp = "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe"
    vStartAdobe = Shell("" & sAdobeApp & " " & sPath & sAdobeFile & "", 1)
    Application.Wait (Now + TimeValue("0:00:01"))
End Sub
Private Sub CopyStep(wsOutp As Worksheet)
    
    ' select all & copy
    SendKeys "^a", True
    SendKeys "^c", True
     Application.Wait (Now + TimeValue("0:00:01"))
   ' Paste into the sheet from cell A1
    wsOutp.Paste Cells(1, 1)
   
    Application.Wait (Now + TimeValue("0:00:01"))
     AppActivate "Adobe Acrobat Reader DC"
    ' close Reader
    SendKeys "%{F4}", True
End Sub

 

[rex759]

I ran the macro on an older computer (peronsal), Windows 7 as opposed to Windows 10 (office 365) (work) and realize I needed to update the reference and check “Adobe Reader File Preview”. Once I did that using my old computer, I got a little further.

I then got held up on

AppActivate "Adobe Acrobat Reader DC"

So I deactivated that line along with

Sendkeys “%{F4}”

and replace it with

SendKeys ("%{F4}")

Now, the program opens the PDFs, copies and pastes it to individual tabs and closes each of the PDFs which is what I want it to do.

However, using my old computer is not feasible and when I move the program to my new computer, it did something a little different. It copied and pasted just the path of each of the PDFs to its own tab instead of the contents of the PDF. I also got the same error messages as before.

Any ideas on how to fix this?

 

[rex759]

I found another sub that seems like its closer to what I want. But the code stops here,

textPDF = objPDF.GetText(1)

with the message "run-time error '-2147221037(800401d3)':
DataObject:Get Test Data on clipboard is invaild

However, I can hit F5 from that point and the code continues to run and complete as expected.

Here is this full code

Public delimiter As String
Sub LoadnConvert()

Dim pathPDF As String, textPDF As String
Dim openPDF As Object
Dim pathCell As Range, fileCell As Range
Dim objPDF As MSForms.DataObject
Dim textArray() As String
Dim i As Integer, j As Integer

'PATH and filename
Set objPDF = New MSForms.DataObject
Set pathCell = Worksheets("data").Range("A1")
Set fileCell = Worksheets("data").Range("A3")

pathPDF = pathCell & fileCell

'IF USER PROVIDED THE FILENAME WITHOUT EXTENSION, ADD IT
i = InStrRev(pathPDF, ".pdf")
If i = 0 Then
    pathPDF = pathPDF & ".pdf"
End If

'ENSURE THAT FILE EXISTS
If Dir(pathPDF) = "" Then
    MsgBox "The filename you provided could not be found!"
Else
    Set openPDF = CreateObject("Shell.Application")
    openPDF.Open (pathPDF)
    'TIME TO WAIT BEFORE/AFTER COPY AND PASTE SENDKEYS
    Application.Wait Now + TimeValue("00:00:2")
    SendKeys "^a"
    Application.Wait Now + TimeValue("00:00:2")
    SendKeys "^c"
    Application.Wait Now + TimeValue("00:00:1")

    'close PDF
    SendKeys ("%{F4}")
 
     AppActivate ActiveWorkbook.Windows(1).Caption
    
    objPDF.GetFromClipboard
    
    textPDF = objPDF.GetText(1)
    textArray = Split(textPDF, vbNewLine)

    j = 1
    For Each Row In textArray
        Dim Col() As String
        'IMPORTANT: DELIMITER THAT SPLITS THE DATA INTO CELLS
        Col = Split(Row, delimiter)
        For i = LBound(Col) To UBound(Col)
            ActiveSheet.Cells(j, i + 1) = Col(i)
        Next i
    j = j + 1
    Next

End If


End Sub

 

[rex759]

Using the second version, I move it to an older machine with Windows 7 and it worked perfectly. Not sure why its getting hung-up on the Gettext command Windows 10. If someone has a way to keep the code moving without having to hit the F5 a second time, I would appreciate it.

textPDF = objPDF.GetText(1)[/CODE

 

[rex759]

Solved!

AppActivate ActiveWorkbook.Windows(1)

All I did was comment this line out and it seems to be working.

 

[rex759]

Spoke too soon. It worked for a few PDFs to copy and paste but then I got the same error message as before

 

[rex759]

Update - I did more trouble shooting and found that the issue is with the pasting into Excel. I commented out the pasting commands and the macro will open, select and copy each PDF one by one correctly to the end of the code. It seems to loose focus when I try to paste the PDFs into Excel. Does anyone have a way around this?

This is what I am currently using

Sub testPaste()
Dim pathPDF As String, textPDF As String
Dim openPDF As Object
Dim pathCell As Range, fileCell As Range
Dim textArray() As String
Dim i As Integer, j As Integer, d As Integer

Worksheets("Sheet1").Range("A1") = "Variances"

'User picks folder, path is loaded to Data tab
  On Error GoTo err
    Dim fileExplorer As FileDialog
    Set fileExplorer = Application.FileDialog(msoFileDialogFolderPicker)
    Dim folderPath As String

    'To allow or disable to multi select
    fileExplorer.AllowMultiSelect = False

    With fileExplorer
        If .Show = -1 Then 'Any folder is selected
            folderPath = .SelectedItems.Item(1)

        Else ' else dialog is cancelled
            MsgBox "You have press cancelled"
            folderPath = "NONE" ' when cancelled set blank as file path.
            Exit Sub
        End If
    End With
err:

ThisWorkbook.Sheets("Data").Range("A1") = folderPath & "\"

'PATH and filename
Set objPDF = New MSForms.DataObject
Set pathCell = Worksheets("data").Range("A1")
   
For d = 2 To 12
    Set fileCell = Worksheets("data").Range("A" & d)

    pathPDF = pathCell & fileCell

'ENSURE THAT FILE EXISTS
If Dir(pathPDF) = "" Then
    MsgBox "The filename you provided could not be found!"
Else
    Set openPDF = CreateObject("Shell.Application")
    openPDF.Open (pathPDF)
    'TIME TO WAIT BEFORE/AFTER COPY AND PASTE SENDKEYS
    Application.Wait Now + TimeValue("00:00:2")
    SendKeys "^a"
    Application.Wait Now + TimeValue("00:00:2")
    SendKeys "^c"
    Application.Wait Now + TimeValue("00:00:4")

    'close PDF
   SendKeys ("%{F4}")

'PROMBLEM AREA+++++++++++++++++++++++++

'LastRow = Worksheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Row + 1
'Range("A" & LastRow).Select
'Selection.PasteSpecial

'+++++++++++++++++++++

'Application.CutCopyMode = False
 
Next d
MsgBox ("Complete!")
End Sub

 

[rex759]

I am guess this is something that cannot be accomplished

 

[rex759]

Bump