用Adobe Acrobat Reader读取PDF数据的VBA代码
下面的代码是一个过程的一部分。 该过程需要来自用户，动作1和动作3的两个动作。动作2中的所有动作都自动发生。 除了CommandButton外，动作3中的所有动作也会自动发生。 那：
操作1）允许用户selectPDF文件
操作2）然后在Acrobat Reader中打开PDF，删除文件名中的坏字符并重新命名，复制用于超链接条目到原始PDF的新文件path，将PDF数据复制到隐藏工作表中，然后隐藏另一个隐藏工作表使用偏移量（索引（VLookUp（按该确切顺序）公式从PDF数据粘贴的工作表中提取我的信息
操作3）UserForm然后允许用户在将数据添加到文档之前查看数据，然后用CommandButton将数据添加到文档，将文档名称超链接到原始文件，并允许用户重复该过程或closures用户窗体。
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 我有一个工作代码，使用Acrobat Reader获取PDF数据。 它使用三张表来收集，parsing并接收最终的数据。 为了我的目的，我把数据收集在一个用户表单中供用户在应用到表单之前进行审查。 我将发布这个代码来回应这个问题。
' 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 '\' ' eg '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