我有一个可以使用Acrobat Reader获取PDF数据的工作代码。它使用三个表格来收集、解析和接收最终数据。为了我的目的，我将数据收集在一个用户窗体中，供用户在将其应用于表格之前进行审查。我会在此回复中发布该代码。
' 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
