VBA Code for Retrieving PDF Data with Adobe Acrobat Reader
I have a working code that gets the PDF data using Acrobat Reader. It uses three sheets to collect, parse, and receive the final data. For my purpose I have the data collected in a UserForm for the User to review before applying it to the sheet. I will post that code in response to this one.
' Declare Type for API call:
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128 ' Maintenance string for PSS usage
End Type
' API declarations:
Private Declare Function GetVersionEx Lib "kernel32" _
Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Sub keybd_event Lib "user32" _
(ByVal bVk As Byte, _
ByVal bScan As Byte, _
ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function GetKeyboardState Lib "user32" _
(pbKeyState As Byte) As Long
Private Declare Function SetKeyboardState Lib "user32" _
(lppbKeyState As Byte) As Long
' Constant declarations:
Const VK_NUMLOCK = &H90
Const VK_SCROLL = &H91
Const VK_CAPITAL = &H14
Const KEYEVENTF_EXTENDEDKEY = &H1
Const KEYEVENTF_KEYUP = &H2
Const VER_PLATFORM_WIN32_NT = 2
Const VER_PLATFORM_WIN32_WINDOWS = 1 '''Private Declare Sub keybd_event Lib "user32" ( _
Function ConcRange(ByRef myRange As Range, Optional ByVal seperator As String = "")
'Used to Concatenate the PDF data that is pasted in separate cells.
ConcRange = vbNullString
Dim rngCell As Range
For Each rngCell In myRange
If ConcRange = vbNullString Then
If Not rngCell.Value = vbNullString Then
ConcRange = CStr(rngCell.Value)
End If
Else
If Not rngCell.Value = vbNullString Then
ConcRange = ConcRange & seperator & CStr(rngCell.Value)
End If
End If
Next rngCell
End Function
Function Concat(rng As Range, Optional sep As String = ",") As String
'Used to Concatenate the PDF data that is pasted in separate cells.
Dim rngCell As Range
Dim strResult As String
For Each rngCell In rng
If rngCell.Value <> "" Then
strResult = strResult & sep & rngCell.Value
End If
Next rngCell
If strResult <> "" Then
strResult = Mid(strResult, Len(sep) + 1)
End If
Concat = strResult
End Function
Function ConcatenateRng()
'Used to Concatenate the PDF data that is pasted in separate cells.
Dim aAddress As Range, bAddress As Range, cRange As Range, x As String, cel As Range, rng As Range
With ActiveWorkbook
Set aAddress = Sheets("Form Input Data").Range("I28").Value
Set bAddress = Sheets("Form Input Data").Range("I29").Value
cResult = aAddress & bAddress
For Each cel In rng
x = x & cel.Value & " "
Next
ActiveWorkbook.Sheets("Form Input Data").Range("I35").Text = Left(x, Len(x) - 2)
End With
End Function
Function ConcRng(myRange, Separator)
'Used to Concatenate the PDF data that is pasted in separate cells.
Dim thecell As cell
FirstCell = True
Set myRangeValues = Sheets("Form Input Data").Range("I42").Value
For Each thecell In myRangeValues
If FirstCell Then
ConcatenateRange = thecell
Else
If Len(thecell) > 0 Then
ConcatenateRange = ConcatenateRange & Separator & thecell
Else
End If
End If
FirstCell = False
Next
End Function
Function GetFilenameFromPath(ByVal strPath As String) As String
' Returns the rightmost characters of a string upto but not including the rightmost '\'
' e.g. 'c:\winnt\win.ini' returns 'win.ini'
If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End If
End Function
Function FileLastModified(ByVal vrtSelectedItem As String) As String
Dim fs As Object, f As Object, s As String
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(vrtSelectedItem)
Set s = f.DateLastModified
's = Format(s, M / d / yyyy)
Sheets("Form Input Data").Range("A66") = s
Set fs = Nothing: Set f = Nothing: Set s = Nothing
End Function
Function DateLastModified(ByVal vrtSelectedItem As String)
Dim strFilename As String
'Put your filename here
strFilename = vrtSelectedItem
'This creates an instance of the MS Scripting Runtime FileSystemObject class
Set oFS = CreateObject("Scripting.FileSystemObject")
Sheets("Form Input Data").Range("A65") = oFS.GetFile(strFilename).DateLastModified
Set oFS = Nothing
End Function
Sub Automatic()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Counter As Integer
Dim RowMax As Integer, ColMax As Integer
Dim r As Integer, c As Integer
Dim PctDone As Single
Sheets("Raw Data").Unprotect
Sheets("Form Input Data").Unprotect
Sheets("Data Tracker ").Unprotect
With Sheet10
.Unprotect
'ClearContents clears data from the RAW Data Sheet
Call ClearContents
End With
Set wsMaster = ThisWorkbook.Sheets("Raw Data") 'This sheet collects the PDF data. Another sheet then looks at this sheet via formulas to get the desired information
Dim fd As FileDialog
Dim Dt As Variant
Dim s As Range
Dim T() As String
Dim N As Long
Set s = Range("A1:A10000")
Dim hWnd
Dim StartDoc
hWnd = apiFindWindow("OPUSAPP", "0")
Dim vrtSelectedItem As Variant
'Application.Visible = True 'Hide Excel Document if desired
'Application.ScreenUpdating = False 'speed up macro execution if desired
Application.DisplayAlerts = False
'Create a FileDialog object as a File Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFilePicker)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With fd
'Use a With...End With block to reference the FileDialog object.
'Use the Show method to display the File Picker dialog box and return the user's action.
'Here we go...
.InitialFileName = "yourfilepath" 'Change this to your file path and used a specific path if a specific folder si the target
If .Show = -1 Then
'The user pressed the action button.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
UserForm2.Hide 'This is the main UserForm where the data ends up. This process can be called from the UserForm or from the Ribbon
UserForm3.Show 'This UserForm is just telling the User that the process is working
With UserForm3
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'switch of updating to speed your code & stop irritating flickering
Application.ScreenUpdating = False
For Each vrtSelectedItem In .SelectedItems
rc = ShellExecute(0, "open", vrtSelectedItem, vbNullChar, _
vbNullChar, 1)
Application.CutCopyMode = True
DoEvents
'IN ACROBAT :
'SELECT ALL
Dim wbProtected As Workbook
If Application.ProtectedViewWindows.Count > 0 Then
Set wbProtected = Application.ProtectedViewWindows(1).Workbook
MsgBox ("PROTECTED")
End If
Application.Wait Now + TimeValue("00:00:05") ' wait
SendKeys "^a", True 'COPY
Application.Wait Now + TimeValue("00:00:03") ' wait
SendKeys "^c", True 'EXIT (Close & Exit)
Application.Wait Now + TimeValue("00:00:03") ' wait
SendKeys "^q"
'Wait some time
Application.Wait Now + TimeValue("00:00:10") ' wait 10 seconds
On Error GoTo ErrPste:
'Paste
DoEvents
90 ActiveWorkbook.Sheets("Raw WAM Data").Paste Destination:=Sheets("Raw WAM Data").Range("A1")
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim FPath As String
Dim Ndx As Integer
Dim FName As String, strPath As String
Dim strFilename As String, strExt As String
Dim NewFileName As String
Dim OldFileName As String
Dim DLM As String
Dim FLM As String
'Replace bad characters in the file name and Rename the file
Const BadChars = "@#()!$/'<|>*-—" ' put your illegal characters here
If Right$(vrtSelectedItem, 1) <> "\" And Len(vrtSelectedItem) > 0 Then
FilenameFromPath = GetFilenameFromPath(Left$(vrtSelectedItem, Len(vrtSelectedItem) - 1)) + Right$(vrtSelectedItem, 1)
'DLM = FileLastModified(vrtSelectedItem)
FLM = DateLastModified(vrtSelectedItem)
End If
'Rename the file
FName = FilenameFromPath
For Ndx = 1 To Len(BadChars)
FName = Replace$(FName, Mid$(BadChars, Ndx, 1), "_")
Next Ndx
GivenLocation = "yourfilepath\" 'note the trailing backslash
OldFileName = vrtSelectedItem
strExt = ".pdf"
NewFileName = GivenLocation & FName
'& strExt
On Error Resume Next
Name OldFileName As NewFileName
On Error GoTo ErrHndlr:
Sheet8.Range("a50") = NewFileName 'pastes new file name into cell
Sheet8.Range("b65") = FLM 'DateLastModfied
Next vrtSelectedItem
Else
End If
End With
On Error GoTo ErrMsg:
Application.ScreenUpdating = False
''''''''''''''''''''''''''''''''''''
'Prep PDF data for UserForm2
Sheet7.Activate
Sheet7.Range("A1:A10000").TextToColumns _
Destination:=Sheet7.Range("A1:A10000").Offset(0, 0), _
DataType:=xlDelimited, _
Tab:=False, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
OTHER:=True, _
OtherChar:=":"
'''''''''''''''''''''''''''''''''''''''''''''''''''
'Copy PDF Data to UserForm2
With UserForm2
'Get filepath for hyperlink
Dim L As String
Dim M As String
L = Sheet8.Range("A50").Value
M = Sheet8.Range("A60").Text
'UserForm2.Show
Set UserForm4 = UserForm2
On Error Resume Next
StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
UserForm4.TextBox1.Value = Sheet8.Range("A20")
UserForm4.TextBox2.Value = Sheet8.Range("A22")
UserForm4.TextBox3.Value = Sheet8.Range("A46")
UserForm4.TextBox5.Value = Sheet8.Range("A23")
UserForm4.TextBox6.Value = Sheet8.Range("A24")
UserForm4.TextBox7.Value = Sheet8.Range("A10")
UserForm4.TextBox8.Value = Sheet8.Range("A55")
UserForm4.TextBox9.Value = Sheet8.Range("A56")
If Sheet8.Range("A58").Value = "#N/A" Then
UserForm4.TextBox20.Value = "Optional if Name is in Title"
Else
UserForm4.TextBox20.Value = Sheet8.Range("A58").Value '.Text
End If
UserForm4.TextBox10.Value = M
UserForm4.TextBox12.Value = Sheet8.Range("A34")
UserForm4.TextBox13.Value = Sheet8.Range("A28")
UserForm4.TextBox14.Value = Sheet8.Range("A26")
UserForm4.TextBox17.Value = Sheet8.Range("A48")
UserForm4.TextBox19.Value = L
UserForm4.TextBox21.Value = Sheet8.Range("A62")
UserForm4.TextBox16.Value = Sheet8.Range("A18")
End With
''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''
'ERRORS'
''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''
ErrPste:
'If Err.Number = 1004 Then
DoEvents
SendKeys "^a", True 'COPY
Application.Wait Now + TimeValue("00:00:10") ' wait
SendKeys "^c", True 'EXIT (Close & Exit)
SendKeys "^q"
'Wait some time
Application.Wait Now + TimeValue("00:00:10") ' wait 10 seconds
'Paste
Resume 90
'End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ErrHndlr:
If Err.Number = 58 Then
MsgBox vrtSelectedItem & " was last modified ON DAY " & DLM
Err.Clear
Resume Next
End If
''''''''''''''''''''''''''''''''''''''''''
ErrMsg:
If Err.Number = 1004 Then
'The User stopped the process
MsgBox "You Cancelled the Operation"
'Sheet10 is my main Sheet where the data ends up
Sheet10.Activate
Exit Sub
End If
'''''''''''''''''''''''''''''''''''''''''''''''
Sheet10.Activate
Application.ScreenUpdating = True 'refreshes the screen
'Hides the "GetData is getting your data UserForm
UserForm3.Hide
'Shows the main UserForm where the User can review the data before applying it to the Final sheet
UserForm2.Show
End Sub
Private Sub ClearContents()
Sheets("Raw Data").Unprotect
Sheets("Form Input Data").Unprotect
With Sheets("Raw Data")
Sheets("Raw Data").Cells.ClearContents
End With
End Sub
Adavid02
Updated on June 27, 2022Comments
-
Adavid02 almost 2 years
The code below is a part of a process. The process requires two actions from the User,Action 1 & Action 3. All of the actions in Action 2 occur automatically. All of the actions in Action 3 also occur automatically with the exception of the CommandButton. that:
Action 1) Allows a User to select a PDF file
Action 2) Then opens the PDF in Acrobat Reader, removes bad characters from a file name and renames it, copies the new filepath which is used to hyperlink the entry to the original PDF, copies the PDF data into a hidden worksheet, then another hidden worksheet uses Offset(Index(VLookUp (in that exact order) formulas to extract my information from the worksheet where the PDF data was pasted
Action 3) A UserForm then allows the User to review the data before adding it to the document, then with a CommandButton adds the data to the document, hyperlinks the document name to the original file, and allows the User either repeat the process or close the UserForm.
Sub GetData() Dim fd As FileDialog Set fd = Application.FileDialog(msoFileDialogFilePicker) 'Create a FileDialog object as a File Picker dialog box Dim vrtSelectedItem As Variant Application.ScreenUpdating = False 'speed up macro execution Application.DisplayAlerts = False ‘Disables error messages 'Sub OPENFILE() With fd 'Use a With...End With block to reference the FileDialog object. 'Use the Show method to display the File Picker dialog box and return the user's action. 'The user pressed the action button. 'On Error GoTo ErrMsg If .Show = -1 Then For Each vrtSelectedItem In .SelectedItems rc = ShellExecute(0, "open", vrtSelectedItem, vbNullChar, _ vbNullChar, 0) Application.CutCopyMode = True 'Wait some time Application.Wait Now + TimeValue("00:00:03") ' wait 3 seconds DoEvents 'IN ACROBAT : 'SELECT ALL DoEvents SendKeys "^a" 'COPY DoEvents SendKeys "^c" 'EXIT (Close & Exit) Application.Wait Now + TimeValue("00:00:02") ' wait 3 seconds DoEvents SendKeys "^q" 'Wait some time Application.Wait Now + TimeValue("00:00:06") ' wait 3 seconds 'Paste DoEvents Sheets("Raw WAM Data").Paste Destination:=Sheets("Raw WAM Data").Range("A1") Sheet8.Range("a50").Value = vrtSelectedItem Application.Wait Now + TimeValue("00:00:03") ' wait 3 seconds 'Replace bad characters in the file name and Rename the file Dim FPath As String Dim Ndx As Integer Dim FName As String, strPath As String Dim strFileName As String, strExt As String Dim NewFileName As String Const BadChars = "@!$/'<|>*-—" ' put your illegal characters here If Right$(vrtSelectedItem, 1) <> "\" And Len(vrtSelectedItem) > 0 Then FilenameFromPath = GetFilenameFromPath(Left$(vrtSelectedItem, Len(vrtSelectedItem) - 1)) + Right$(vrtSelectedItem, 1) End If FName = FilenameFromPath For Ndx = 1 To Len(BadChars) FName = Replace$(FName, Mid$(BadChars, Ndx, 1), "_") Next Ndx GivenLocation = _ SRV006\Am\Master Documents\PC 2.2.11 Document For Work(DFWs)\DFWS added to DFW Track\" 'note the trailing backslash OldFileName = vrtSelectedItem strExt = ".pdf" NewFileName = GivenLocation & FName & strExt Name vrtSelectedItem As NewFileName 'The next three lines are not used but can be if you do not want to rename the file 'FPath = vrtSelectedItem 'Fixing the File Path 'FPath = (Right(FPath, Len(FPath) - InStr(FPath, "#"))) 'FPath = "\\" & FPath 'pastes new file name into cell to be used with the UserForm Sheet8.Range("a50") = NewFileName Next vrtSelectedItem Else End End With On Error GoTo ErrMsg: ErrMsg: If Err.Number = 1004 Then MsgBox "You Cancelled the Operation" ‘The User pressed cancel Exit Sub End If ‘This delimits my data so I can use the Offset(Index(VLookUp formulas to locate the information on the RAW sheet Sheet7.Activate Sheet7.Range("A1:A1000").TextToColumns _ Destination:=Sheet7.Range("A1:A1000").Offset(0, 0), _ DataType:=xlDelimited, _ Tab:=False, _ Semicolon:=False, _ Comma:=False, _ Space:=False, _ OTHER:=True, _ OtherChar:=":" ‘Now the UserForm launches with the desired data already in the TextBoxes With UserForm2 Dim h As String h = Sheet8.Range("A50").Value ‘This is my Hyperlink to the file UserForm2.Show Set UserForm4 = UserForm2 On Error Resume Next StartUpPosition = 0 .Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width) .Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height) UserForm4.TextBox1.Value = Sheet8.Range("A20") UserForm4.TextBox2.Value = Sheet8.Range("A22") UserForm4.TextBox3.Value = Sheet8.Range("A7") UserForm4.TextBox5.Value = Sheet8.Range("A23") UserForm4.TextBox6.Value = Sheet8.Range("A24") UserForm4.TextBox7.Value = Sheet8.Range("A10") UserForm4.TextBox10.Value = Date UserForm4.TextBox12.Value = Sheet8.Range("A34") UserForm4.TextBox13.Value = Sheet8.Range("A28") UserForm4.TextBox14.Value = Sheet8.Range("A26") UserForm4.TextBox17.Value = Sheet8.Range("A12") UserForm4.TextBox19.Value = h UserForm4.TextBox16.Value = Sheet8.Range("A18") End With Application.ScreenUpdating = True 'refreshes the screen End Sub