如何批量获取目录下PDF文件内容

某某某841

想到一个折衷的办法，如果想要结果显示在一个excel表里，可以先将多个pdf文件合并成一个，然后再用大神的语句转换。

某某某841

哦，漏看了要求每个pdf单独sheet

某某某841

Public PDF_PATH As String
Sub cmd_imp_Click()

Dim OS_FSO As Object
Set OS_FSO = CreateObject("Scripting.filesystemobject")
Dim Dlg_File As FileDialog
Dim PDF_FILE As String


Set Dlg_File = Application.FileDialog(msoFileDialogFilePicker)


PDF_PATH = Dir(ThisWorkbook.Path & "\" & "*.pdf")

Do

'With Dlg_File
   '.Filters.Add "PDF文件", "*.pdf"
  ' If .Show = -1 Then
        'PDF_Path = .SelectedItems(1)
  'End If
'End With

'If OS_FSO.fileexists(PDF_Path) = False Then
   ' MsgBox "PDF文件没有找到"
  ' Set OS_FSO = Nothing
  ' Exit Sub
'End If

PDF_FILE = ThisWorkbook.Path & "\" & PDF_PATH
Call Imp_Into_XL(PDF_FILE)

PDF_PATH = Dir

Loop Until Len(PDF_PATH) = 0
MsgBox "完成"
End Sub

Sub Imp_Into_XL(PDF_FILE As String)

Dim AC_PD As New Acrobat.AcroPDDoc
Dim AC_Hi As Acrobat.AcroHiliteList
Dim AC_PG As Acrobat.AcroPDPage
Dim AC_PGTxt As Acrobat.AcroPDTextSelect

Dim WS_PDF As Worksheet

Dim RW_Ct As Long
Dim Col_Num As Integer
Dim Li_Row As Long
Dim Yes_Fir As Boolean

Li_Row = Rows.Count

Dim Ct_Page As Long
Dim i As Long, j As Long, k As Long
Dim T_Str As String

Dim Hld_Txt As Variant

RW_Ct = 0
Col_Num = 1

Application.ScreenUpdating = False

Set AC_PD = New Acrobat.AcroPDDoc
Set AC_Hi = New Acrobat.AcroHiliteList

AC_Hi.Add 0, 32767

With AC_PD


   .Open PDF_FILE

    Ct_Page = .GetNumPages
   
    If Ct_Page = -1 Then
        MsgBox "请确认PDF文件 '" & PDF_FILE & "'"
        .Close
        GoTo h_end
    End If

    For Each WS_PDF In Sheets
      Application.DisplayAlerts = False
        If WS_PDF.Name = PDF_PATH Then WS_PDF.Delete
      Application.DisplayAlerts = True
    Next

    Set WS_PDF = Worksheets.Add(, Worksheets(Sheets.Count))
    WS_PDF.Name = PDF_PATH

    For i = 1 To Ct_Page
        T_Str = ""
        Set AC_PG = .AcquirePage(i - 1)
        Set AC_PGTxt = AC_PG.CreateWordHilite(AC_Hi)

        If Not AC_PGTxt Is Nothing Then
            With AC_PGTxt
                For j = 0 To .GetNumText - 1
                    T_Str = T_Str & .GetText(j)
                Next j
            End With
        End If

        With WS_PDF

             If T_Str <> "" Then

                Hld_Txt = Split(T_Str, vbCrLf)

                 Yes_Fir = True

                 For k = 0 To UBound(Hld_Txt)

                      RW_Ct = RW_Ct + 1

                      If Yes_Fir Then
                         RW_Ct = RW_Ct + 1
                        .Cells(RW_Ct, Col_Num).Value = "第" & i & "页"
                         RW_Ct = RW_Ct + 2
                         Yes_Fir = False
                      End If

                       If RW_Ct > Li_Row Then
                          RW_Ct = 1
                           Col_Num = Col_Num + 1
                        End If

                        T_Str = CStr(Hld_Txt(k))
                        If Left(T_Str, 1) = "=" Then T_Str = "'" & T_Str
                        .Cells(RW_Ct, Col_Num).Value = T_Str

                   Next k

                 Else

                    RW_Ct = RW_Ct + 1
                    .Cells(RW_Ct, Col_Num).Value = "页面无文字 " & i
                     RW_Ct = RW_Ct + 1

                 End If

         End With
    Next i

    .Close

End With

Application.ScreenUpdating = True



h_end:

Set WS_PDF = Nothing
Set AC_PGTxt = Nothing
Set AC_PG = Nothing
Set AC_Hi = Nothing
Set AC_PD = Nothing



End Sub

某某某841

可以试试这个，貌似成功了。而且可以PDF文件名给EXCEL的SHEET表命名。但是PDF文件与EXCEl文件要在同一个文件夹下。

某某某841

Ericcccccc 发表于 2019-3-11 09:46
If Ct_Page = -1 Then
        MsgBox "请确认PDF文件 '" & PDF_File & "'"
代码运行到在这里卡住 ...

应该是大神原来的PDF_PATH是个路径，而更改成循环模式后,PDF_path变成了文件名。因此第二段代码找不到这个文件，所以才会识别页码为-1.

Ericcccccc

某某某841 发表于 2019-4-15 11:46
应该是大神原来的PDF_PATH是个路径，而更改成循环模式后,PDF_path变成了文件名。因此第二段代码找不到这 ...

追了这么久的问题解决了，非常感谢

MaterFu

要借助activex控件的