Hello,
I got the code from this site and it seems to error on
I receive two error messages,
Any ideas?
I got the code from this site and it seems to error on
VBA Code:
vStartAdobe = Shell("" & sAdobeApp & " " & sPath & sAdobeFile & "", 1)
I receive two error messages,
- There was an error opening this document. Access denied.
- There was an error opening this document. Document cannot be found.
Any ideas?
VBA Code:
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