excel - 使用 Adob​​e Acrobat Reader 检索 PDF 数据的 VBA 代码

Question

下面的代码是一个过程的一部分。该过程需要用户执行两个操作，操作 1 和操作 3。操作 2 中的所有操作都会自动发生。除命令按钮外，操作 3 中的所有操作也会自动发生。那:

操作 1) 允许用户选择 PDF 文件

操作 2) 然后在 Acrobat Reader 中打开 PDF，从文件名中删除错误字符并重命名，复制用于将条目超链接到原始 PDF 的新文件路径，将 PDF 数据复制到隐藏的工作表中，然后另一个隐藏的工作表使用 Offset(Index(VLookUp (in that exact order) 公式从粘贴 PDF 数据的工作表中提取我的信息

操作 3) 然后用户窗体允许用户在将数据添加到文档之前查看数据，然后使用命令按钮将数据添加到文档，将文档名称超链接到原始文件，并允许用户重复处理或关闭用户窗体。

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

Answer 1

我有一个使用 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