Đọc tập tin pdf và đưa vào Excel

Liên hệ QC

levanduyet

Hãy để gió cuốn đi.
Thành viên danh dự
Tham gia
30/5/06
Bài viết
1,798
Được thích
4,704
Giới tính
Nam
Có nhiều cách đọc tập tin pdf, ở đây tôi xin giới thiệu cách đọc tập tin pdf sử dụng công cụ xpdfreader.
http://www.xpdfreader.com/download.html
Trong ví dụ sau tôi sử dụng pdftotext (tức là chuyển pdf sang tập tin text) và sau đó sẽ đưa vào Excel.
1, Đầu tiên các bạn theo link trên tải về, giải nén và copy tập tin pdftotext.exe vào thư mục có chứa tập tin pdf muốn đọc.
2, Thay đổi các thông số ở sheet Setting trong tập tin Excel tôi upload lên cho phù hợp với yêu cầu của mình.
3, Thử chạy bằng việc nhấn vào nút Lấy dữ liệu cũng trong sheet Setting. Kết quả sẽ đưa vào sheet Result.

Code sau:
Rich (BB code):
'---------------------------------------------------------------------------------------
' Method : MoFilePdf
' Author : Doit
' Date   : 07/04/2019
' Purpose: Nham doc file pdf va dua vao Excel
'
'          Tai pdftotext tai http://www.xpdfreader.com/download.html
'          Tham khao tai lieu tai http://www.xpdfreader.com/pdftotext-man.html
'---------------------------------------------------------------------------------------
Sub MoFilePdf()

    Dim sFolderPath As String, sBatFileName As String, sPdfFileName As String, sTxtFileNamePath As String
    Dim sPdfExeFolder As String, sTxtFileName As String, FileNumber As Integer, sData As String
    Dim lRow As Long
    Dim PID As Variant
    Dim wsSetting As Worksheet, wsResult As Worksheet

    On Error GoTo MoFilePdf_Error

    ' Nham tang toc do thuc hien
    Application.EnableEvents = False    'Disable Excel Events
    Application.ScreenUpdating = False    'Turn Off Screen Updating to eliminate Screen Flicker and to improve speed performance

    ' Lay ten cac tap tin
    '=====================
    Set wsSetting = ThisWorkbook.Worksheets("Setting")
    Set wsResult = ThisWorkbook.Worksheets("Result")
    sFolderPath = wsSetting.Range("E2")
    sPdfFileName = wsSetting.Range("E3")
    sBatFileName = wsSetting.Range("E4")
    sTxtFileName = wsSetting.Range("E5")
    sTxtFileNamePath = sFolderPath & "\" & sTxtFileName
    sPdfExeFolder = wsSetting.Range("E6")

    ' Tao tap tin bat
    '=================
    FileNumber = FreeFile
    Open sBatFileName For Output As #FileNumber
    ' Chuyen ve thu muc tap tin pdftotext.exe
    Print #FileNumber, "cd " & sPdfExeFolder
    ' Lenh ke tiep cho chay chuong trinh pdftotext.exe voi cac tham so thiet lap truoc
    ' Chu y: su dung Chr(34) cho dau ngoac kep
    Print #FileNumber, "pdftotext.exe -layout " & Chr(34) & sPdfFileName & Chr(34) & " " & Chr(34) & sTxtFileName & Chr(34)
    ' Lenh ke tiep la thoat
    Print #FileNumber, "exit"
    Close #FileNumber

    ' Thuc thi batFile
    ' ================
    PID = Shell(sBatFileName, vbNormalFocus)
    If Err.Number <> 0 Then
        ' Neu co loi thi di den bay loi va thong bao
        GoTo MoFilePdf_Error
    End If
    ' Tiep tuc dua du lieu ra sheet Result
    ' =====================================
    FileNumber = FreeFile
    ' Hang dau de xuat du lieu
    lRow = 1
    wsResult.Cells.Clear    ' Xoa du lieu truoc khi xuat ra
    Open sTxtFileNamePath For Input As FileNumber
    Do While Not EOF(FileNumber)
        Line Input #FileNumber, sData
        wsResult.Cells(lRow, 1) = sData
        lRow = lRow + 1
    Loop
    Close #FileNumber

    ' Neu thanh cong thi thong bao
    MsgBox "Ban da lay du lieu tu tap tin pdf thanh cong.", vbOKOnly, "Thong bao"

MoFilePdf_Exit:
    ' Giai phong bien/release memory
    Set wsSetting = Nothing
    Set wsResult = Nothing

    ' Tra lai tinh trang ban dau
    Application.EnableEvents = True    'Enable Excel Events
    Application.ScreenUpdating = True    'Enable Screen Updating
    Exit Sub

MoFilePdf_Error:
    ' vbCrLf la ky tu xuong dong
    MsgBox "Loi " & Err.Number & " (" & Err.Description & ")." & vbCrLf & "Vui long kiem tra lai.", vbOKOnly + vbInformation, "Thong bao"

End Sub

Trong code ở trên tôi có giải thích.

Hy vọng đây cũng là một ví dụ tham khảo giúp ích cho các bạn.

Lê Văn Duyệt
 

File đính kèm

  • ReadPdfFile.xlsm
    32.1 KB · Đọc: 206
Có nhiều cách đọc tập tin pdf, ở đây tôi xin giới thiệu cách đọc tập tin pdf sử dụng công cụ xpdfreader.
http://www.xpdfreader.com/download.html
Trong ví dụ sau tôi sử dụng pdftotext (tức là chuyển pdf sang tập tin text) và sau đó sẽ đưa vào Excel.
1, Đầu tiên các bạn theo link trên tải về, giải nén và copy tập tin pdftotext.exe vào thư mục có chứa tập tin pdf muốn đọc.
2, Thay đổi các thông số ở sheet Setting trong tập tin Excel tôi upload lên cho phù hợp với yêu cầu của mình.
3, Thử chạy bằng việc nhấn vào nút Lấy dữ liệu cũng trong sheet Setting. Kết quả sẽ đưa vào sheet Result.

Code sau:
Rich (BB code):
'---------------------------------------------------------------------------------------
' Method : MoFilePdf
' Author : Doit
' Date   : 07/04/2019
' Purpose: Nham doc file pdf va dua vao Excel
'
'          Tai pdftotext tai http://www.xpdfreader.com/download.html
'          Tham khao tai lieu tai http://www.xpdfreader.com/pdftotext-man.html
'---------------------------------------------------------------------------------------
Sub MoFilePdf()

    Dim sFolderPath As String, sBatFileName As String, sPdfFileName As String, sTxtFileNamePath As String
    Dim sPdfExeFolder As String, sTxtFileName As String, FileNumber As Integer, sData As String
    Dim lRow As Long
    Dim PID As Variant
    Dim wsSetting As Worksheet, wsResult As Worksheet

    On Error GoTo MoFilePdf_Error

    ' Nham tang toc do thuc hien
    Application.EnableEvents = False    'Disable Excel Events
    Application.ScreenUpdating = False    'Turn Off Screen Updating to eliminate Screen Flicker and to improve speed performance

    ' Lay ten cac tap tin
    '=====================
    Set wsSetting = ThisWorkbook.Worksheets("Setting")
    Set wsResult = ThisWorkbook.Worksheets("Result")
    sFolderPath = wsSetting.Range("E2")
    sPdfFileName = wsSetting.Range("E3")
    sBatFileName = wsSetting.Range("E4")
    sTxtFileName = wsSetting.Range("E5")
    sTxtFileNamePath = sFolderPath & "\" & sTxtFileName
    sPdfExeFolder = wsSetting.Range("E6")

    ' Tao tap tin bat
    '=================
    FileNumber = FreeFile
    Open sBatFileName For Output As #FileNumber
    ' Chuyen ve thu muc tap tin pdftotext.exe
    Print #FileNumber, "cd " & sPdfExeFolder
    ' Lenh ke tiep cho chay chuong trinh pdftotext.exe voi cac tham so thiet lap truoc
    ' Chu y: su dung Chr(34) cho dau ngoac kep
    Print #FileNumber, "pdftotext.exe -layout " & Chr(34) & sPdfFileName & Chr(34) & " " & Chr(34) & sTxtFileName & Chr(34)
    ' Lenh ke tiep la thoat
    Print #FileNumber, "exit"
    Close #FileNumber

    ' Thuc thi batFile
    ' ================
    PID = Shell(sBatFileName, vbNormalFocus)
    If Err.Number <> 0 Then
        ' Neu co loi thi di den bay loi va thong bao
        GoTo MoFilePdf_Error
    End If
    ' Tiep tuc dua du lieu ra sheet Result
    ' =====================================
    FileNumber = FreeFile
    ' Hang dau de xuat du lieu
    lRow = 1
    wsResult.Cells.Clear    ' Xoa du lieu truoc khi xuat ra
    Open sTxtFileNamePath For Input As FileNumber
    Do While Not EOF(FileNumber)
        Line Input #FileNumber, sData
        wsResult.Cells(lRow, 1) = sData
        lRow = lRow + 1
    Loop
    Close #FileNumber

    ' Neu thanh cong thi thong bao
    MsgBox "Ban da lay du lieu tu tap tin pdf thanh cong.", vbOKOnly, "Thong bao"

MoFilePdf_Exit:
    ' Giai phong bien/release memory
    Set wsSetting = Nothing
    Set wsResult = Nothing

    ' Tra lai tinh trang ban dau
    Application.EnableEvents = True    'Enable Excel Events
    Application.ScreenUpdating = True    'Enable Screen Updating
    Exit Sub

MoFilePdf_Error:
    ' vbCrLf la ky tu xuong dong
    MsgBox "Loi " & Err.Number & " (" & Err.Description & ")." & vbCrLf & "Vui long kiem tra lai.", vbOKOnly + vbInformation, "Thong bao"

End Sub

Trong code ở trên tôi có giải thích.

Hy vọng đây cũng là một ví dụ tham khảo giúp ích cho các bạn.

Lê Văn Duyệt

Xin chào chú levanduyet,
Cảm ơn chú đã chia sẻ ạ, OT thực hiện theo cách chú hướng dẫn . Nhưng khi tải về tập tin có dạng sau"XpdfReader-win64-4.01.01.exe.sig"
Không giải nén được nữa. Có thể do tải không đúng tập tin?
Chú có thể cho hết các thứ liên quan vào 1 thư mục rồi nén lại sau đó up lên đây được không ạ.
Cháu cảm ơn chú Duyệt.
 
Upvote 0
Xin chào chú levanduyet,
Cảm ơn chú đã chia sẻ ạ, OT thực hiện theo cách chú hướng dẫn . Nhưng khi tải về tập tin có dạng sau"XpdfReader-win64-4.01.01.exe.sig"
Không giải nén được nữa. Có thể do tải không đúng tập tin?
Chú có thể cho hết các thứ liên quan vào 1 thư mục rồi nén lại sau đó up lên đây được không ạ.
Cháu cảm ơn chú Duyệt.
Bạn cứ vào link ở trên và nhấn Download để tải về mà thôi.
214814
 
Upvote 0
Chào thầy @levanduyet và các thầy cô, anh chị

Cám ơn thầy đã hướng dẫn và chia sẻ file đọc tập tin pdf và input nội dung vào excel rất hay
Em đã thực hiện theo bài viết của thầy và thành công

Tuy nhiên, em có một mong muốn mong thầy giúp đỡ
Đó là sử dụng file của thấy để 1 lần có thể đọc được hết toàn bộ tệp tin pdf trong 1 thư mục
Do file của thầy 1 lần chỉ đọc 1 file mà trong thư mục của em có khoảng mấy chục file

Em đã thử code sau chạy qua cmd và thành công, 1 lần có thể chạy toàn bộ file trong thư mục
Tuy nhiên em muốn dùng thông qua vba để giảm thiểu các bước, đồng thời để cho một số người khác không rành vẫn có thể thực hiện được

Vậy mong thầy hướng dẫn giúp em phải sửa code vba trong file như thế nào để có thể đọc được toàn bộ file pdf trong 1 thư mục như code cmd bên dưới

Em cám ơn thầy

for /r %i in (*.pdf) do "C:\Users\Crystal199\Desktop\GETDATA\pdftotext" -layout "%i"
 
Upvote 0
Cảm ơn anh. E đã thử và thành công. Tuy nhiên nó đọc File tiếng việt bị lỗi Font. Có cách nào khắc phục được không anh ??
 
Upvote 0
Cảm ơn anh. E đã thử và thành công. Tuy nhiên nó đọc File tiếng việt bị lỗi Font. Có cách nào khắc phục được không anh ??
Code đấy không lấy được văn bản tiếng Việt đâu.

5 năm trước tôi cũng từng dùng pdftotext.exe.

Bạn hãy thử code tôi viết dưỡi đây.

Lưu ý:
1. Tập tin Excel cùng code và pdftotext.exe phải cùng thư mục. Hoặc sửa trong code đường dẫn tới pdftotext.exe (sửa trong sub test)

2. Nếu muốn làm với hàng loat PDF thì nhập các đường dẫn vào mảng Arr (sub test). Hoặc chạy code trong vòng FOR và trong mỗi vòng thay "c:\hichic.pdf" bằng đường dẫn hiện hành. Tức ta có thể lấy tất cả các đường dẫn tới PDF trong 1 thư mục vào mảng rồi truyền mảng đó vào sub PDF2TXT với tư cách là Arr

3. với mỗi tập tin PDF là hichic.pdf thì kết quả là tập tin hichic_ngaythangnamgiophutgiay.txt trong cùng thư mục với hichic.pdf

Mã:
Public Sub PDF2TXT(Arr, ByVal pdftotext_fullname As String, Optional ByVal first_page As Long = 0, _
    Optional ByVal last_page As Long = 0, Optional ByVal method As String = "", _
    Optional ByVal encode As String = "UTF-8", Optional ByVal page_break As Boolean = False, _
    Optional ByVal password As String = "")
Dim wShell As Object, comm As String
    Set wShell = CreateObject("WScript.Shell")
    If first_page > 0 And first_page <= last_page Then comm = "-f " & first_page & " -l " & last_page & " "
    If method <> "" Then comm = comm & "-" & method & " "
    If encode = "" Then encode = "UTF-8"
    comm = comm & "-enc " & encode & " "
    If Not page_break Then comm = comm & "-nopgbrk "
    If password <> "" Then comm = comm & "-opw " & password & " "
    comm = Chr(34) & pdftotext_fullname & Chr(34) & " " & comm
    For k = LBound(Arr) To UBound(Arr)
        Filename = Left(Arr(k), InStrRev(Arr(k), ".") - 1) & "_" & Format(Now, "ddmmyyyyhhmmss") & ".txt"
        wShell.Run comm & Chr(34) & Arr(k) & Chr(34) & Chr(32) & Chr(34) & Filename & Chr(34), 0, True
    Next k
    Set wShell = Nothing
End Sub

Sub test()
Dim Arr
    Arr = Array("c:\hichic.pdf")
    PDF2TXT Arr, ThisWorkbook.Path & "\pdftotext.exe", , , "raw"
End Sub
 
Upvote 0
Code đấy không lấy được văn bản tiếng Việt đâu.

5 năm trước tôi cũng từng dùng pdftotext.exe.

Bạn hãy thử code tôi viết dưỡi đây.

Lưu ý:
1. Tập tin Excel cùng code và pdftotext.exe phải cùng thư mục. Hoặc sửa trong code đường dẫn tới pdftotext.exe (sửa trong sub test)

2. Nếu muốn làm với hàng loat PDF thì nhập các đường dẫn vào mảng Arr (sub test). Hoặc chạy code trong vòng FOR và trong mỗi vòng thay "c:\hichic.pdf" bằng đường dẫn hiện hành. Tức ta có thể lấy tất cả các đường dẫn tới PDF trong 1 thư mục vào mảng rồi truyền mảng đó vào sub PDF2TXT với tư cách là Arr

3. với mỗi tập tin PDF là hichic.pdf thì kết quả là tập tin hichic_ngaythangnamgiophutgiay.txt trong cùng thư mục với hichic.pdf

Mã:
Public Sub PDF2TXT(Arr, ByVal pdftotext_fullname As String, Optional ByVal first_page As Long = 0, _
    Optional ByVal last_page As Long = 0, Optional ByVal method As String = "", _
    Optional ByVal encode As String = "UTF-8", Optional ByVal page_break As Boolean = False, _
    Optional ByVal password As String = "")
Dim wShell As Object, comm As String
    Set wShell = CreateObject("WScript.Shell")
    If first_page > 0 And first_page <= last_page Then comm = "-f " & first_page & " -l " & last_page & " "
    If method <> "" Then comm = comm & "-" & method & " "
    If encode = "" Then encode = "UTF-8"
    comm = comm & "-enc " & encode & " "
    If Not page_break Then comm = comm & "-nopgbrk "
    If password <> "" Then comm = comm & "-opw " & password & " "
    comm = Chr(34) & pdftotext_fullname & Chr(34) & " " & comm
    For k = LBound(Arr) To UBound(Arr)
        Filename = Left(Arr(k), InStrRev(Arr(k), ".") - 1) & "_" & Format(Now, "ddmmyyyyhhmmss") & ".txt"
        wShell.Run comm & Chr(34) & Arr(k) & Chr(34) & Chr(32) & Chr(34) & Filename & Chr(34), 0, True
    Next k
    Set wShell = Nothing
End Sub

Sub test()
Dim Arr
    Arr = Array("c:\hichic.pdf")
    PDF2TXT Arr, ThisWorkbook.Path & "\pdftotext.exe", , , "raw"
End Sub
Có anh ra tay ( mạn phép kêu anh vì có thể biết a lớn) thì chưa thử nhưng e có đường đi rồi. Em sẽ test và phản hồi. Cảm ơn anh !
Bài đã được tự động gộp:

Quá tuyệt vời. Đã xử lý được File PDF tiếng việt có dấu. Cảm ơn anh lần nữa !
 
Lần chỉnh sửa cuối:
Upvote 0
Có anh ra tay ( mạn phép kêu anh vì có thể biết a lớn) thì chưa thử nhưng e có đường đi rồi. Em sẽ test và phản hồi. Cảm ơn anh !
Bài đã được tự động gộp:

Quá tuyệt vời. Đã xử lý được File PDF tiếng việt có dấu. Cảm ơn anh lần nữa !
thử rồi ... chạy tốt đó nhớ Dim k, Filename
 
Upvote 0
thử rồi ... chạy tốt đó nhớ Dim k, Filename
À, mình thêm rồi. Anh @batman1 cho em hỏi là:
Theo cách của a Duyệt thì nó ra dữ liệu trên File Text theo từng hàng, từng cột giống gần như nguyên mẫu File PDF, nhưng lỗi Font
Theo cách code của a thì nó ra dữ liệu trên file text theo từng dòng và hầu như bố cục không theo nguyên tắc nào nên e khó có thể 'xào' tiếp . Vì trên file gốc PDF e có thể chỉ cần lấy 1 vài dữ liệu dựa vào các từ khóa. Mong a xem lại thử. Cảm ơn anh !
 
Upvote 0
À, mình thêm rồi. Anh @batman1 cho em hỏi là:
Theo cách của a Duyệt thì nó ra dữ liệu trên File Text theo từng hàng, từng cột giống gần như nguyên mẫu File PDF, nhưng lỗi Font
Theo cách code của a thì nó ra dữ liệu trên file text theo từng dòng và hầu như bố cục không theo nguyên tắc nào nên e khó có thể 'xào' tiếp . Vì trên file gốc PDF e có thể chỉ cần lấy 1 vài dữ liệu dựa vào các từ khóa. Mong a xem lại thử. Cảm ơn anh !
bạn tham khảo các tham số của tool nhé, anh batman dùng tham số raw nên thế, bạn dùng tham số khác như simple hoặc layout...
 
Upvote 0
Bác Duyệt chỉ đưa ra một giải pháp tạm thời.
Tuy nhiên từ Office 2013 cho đến thời điểm hiện tại trong ứng dụng Word đã sử dụng thư viện PDF REFLOW dư sức để chuyển đổi PDF ưu việt.
Và PDF là một file được Scan thì thêm giải pháp khác là ứng dụng ABBYY FINEREADER, chuyển đổi Hình ảnh sang cấu trúc dữ liệu số.

Dựa trên các cơ sở Code ở trên và phương thức chuyển đổi từ xpdf, code dưới đây sẽ tự động hóa hoàn toàn, mà không phải qua bước Download thủ công.

Thủ tục ListAllFiles

JavaScript:
Option Explicit
#Const EarlyBinding = False
Public Const DicsPDF = "\FilesPDF\"
#If VBA7 Then
  Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
  (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
  ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#Else
  Private Declare  Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
  (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
  ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If

Private Sub test_PDF2TXT_xPDF()
  Dim Arr
  Arr = Array("*1.pdf", "*2.pdf")
  'Tham khảo hàm ListAllFiles
  'ListAllFiles "D:\", , Arr, True, ".pdf"
  PDF2TXT_xPDF Arr
End Sub


Sub PDF2TXT_xPDF(Arr, _
  Optional ByVal first_page As Long = 0, _
  Optional ByVal last_page As Long = 0, _
  Optional ByVal method As String = "raw", _
  Optional ByVal encode As String = "UTF-8", _
  Optional ByVal page_break As Boolean = False, _
  Optional ByVal password As String = "")
  Dim pdfEXE$
  pdfEXE = EXE_xPDF & "pdftotext.exe"
  Dim wShell As Object, comm$, K%, FileName$
  Set wShell = CreateObject("WScript.Shell")
  If first_page > 0 And first_page <= last_page Then comm = "-f " & first_page & " -l " & last_page & " "
  If method <> "" Then comm = comm & "-" & method & " "
  If encode = "" Then encode = "UTF-8"
  comm = comm & "-enc " & encode & " "
  If Not page_break Then comm = comm & "-nopgbrk "
  If password <> "" Then comm = comm & "-opw " & password & " "
  comm = Chr(34) & pdfEXE & Chr(34) & " " & comm
  For K = LBound(Arr) To UBound(Arr)
    'Dùng CountPagesPDF(Arr(K)) để giới hạn số Trang'
    FileName = Left(Arr(K), InStrRev(Arr(K), ".") - 1) & "_" & Format(Now, "ddmmyyyyhhmmss") & ".txt"
    wShell.Run comm & Chr(34) & Arr(K) & Chr(34) & Chr(32) & Chr(34) & FileName & Chr(34), 0, -1
  Next K
  Set wShell = Nothing
End Sub


Function CountPagesPDF&(ByVal FullPath$)
  On Error Resume Next
  #If EarlyBinding Then
    Dim RegExp As RegExp
    Set RegExp = New RegExp
  #Else
    Dim RegExp As Object
    #If Win64 Then
      Set RegExp = CreateObject("VBscript.RegExp.5.5")
    #Else
      Set RegExp = CreateObject("VBscript.RegExp")
    #End If
  #End If
  Dim xFileNum&, xStr$
  RegExp.Global = True
  RegExp.Pattern = "/Type\s*/Page[^s]"
  xFileNum = FreeFile
  Open (FullPath) For Binary As #xFileNum
      xStr = Space(LOF(xFileNum))
      Get #xFileNum, , xStr
  Close #xFileNum
  CountPagesPDF = RegExp.Execute(xStr).Count
  Set RegExp = Nothing
End Function


Function EXE_xPDF() As String
  #If Mac Then
    Exit Function
  #End If
  Const p_xPDF = "http://www.xpdfreader.com/download.html"
  Dim Temp$, dURL$, Doc, nFile$, fFile$, fFolder$, Ext$, Name$, L%
  Temp = IIf(Environ$("Tmp") <> "", Environ$("Tmp"), Environ$("Temp")) & Application.PathSeparator

  #If EarlyBinding Then
    Dim FSO As Scripting.FileSystemObject
    Set FSO = New Scripting.FileSystemObject
  #Else
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
  #End If
  Dim Sh As Object
  Set Sh = CreateObject("Shell.Application")
  Dim Item, sFolder

  Set sFolder = FSO.GetFolder(Temp)

  #If Win64 Then
      Const bin = "bin64\"
  #Else
      Const bin = "bin32\"
  #End If
  For Each Item In sFolder.SubFolders
    If LCase$(Item.Path) Like "*xpdf*win*" Then
      EXE_xPDF = Item.Path & Application.PathSeparator & bin: Exit Function
    End If
  Next Item
  Set Doc = HTMLResponse(p_xPDF)
  If Doc Is Nothing Then Exit Function
  Dim Li
  For Each Li In Doc.getElementsByTagName("li")
    If LCase$(Li.innerText) Like "*window*32/64*bit*" Then
      dURL = Li.getElementsByTagName("a")(0).getAttribute("href")
      Exit For
    End If
  Next
  If Not dURL Like "*/*" Then Exit Function
  L = InStrRev(dURL, "/")
  nFile = Right$(dURL, Len(dURL) - L)
  L = InStrRev(nFile, ".")
  Name = Left$(nFile, L - 1)
  Ext = Right$(nFile, Len(nFile) - L)
  fFile = Temp & nFile
  fFolder = Temp & Name: L = 0
  If Not FSO.FolderExists(fFolder) Then
    On Error Resume Next
      If Not FSO.FileExists(fFile) Then
        If URLDownloadToFile(0, dURL, fFile, 0, 0) = 0 Then
          Do Until FSO.FileExists(fFile)
            Application.Wait Now + TimeSerial(0, 0, 1)
            L = L + 1: If L > 20 Then Exit Do
            DoEvents
          Loop
        End If
      End If
      Application.Wait Now + TimeSerial(0, 0, 1)
      With Sh
        .Namespace(CVar(Temp)).CopyHere .Namespace(CVar(fFile)).items, &H10&
      End With
      FSO.DeleteFile fFile, True
    On Error GoTo 0
  End If
  EXE_xPDF = fFolder & Application.PathSeparator & bin
  Set FSO = Nothing: Set Sh = Nothing
End Function

Function HTMLResponse(Url$) As Object
  On Error Resume Next
    Dim oHttp As Object, Doc As Object
    Set Doc = CreateObject("HTMLFile")
    #If Win64 Then
      Set oHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    #Else
      Set oHttp = CreateObject("MSXML2.ServerXMLHTTP")
    #End If

  With oHttp
    .Open "GET", Url, False
    .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/74.0.3729.131 Safari/537.36"
    .setRequestHeader "Content-type", "application/x-www-form-urlencoded"
    .Send ""
    If .Status = 200 Then
      Doc.body.innerHTML = .responseText
      Set HTMLResponse = Doc
    End If
    Set Doc = Nothing
  End With
  Set oHttp = Nothing
End Function
 
Lần chỉnh sửa cuối:
Upvote 1
Bác Duyệt chỉ đưa ra một giải pháp tạm thời.
Tuy nhiên từ Office 2013 cho đến thời điểm hiện tại trong ứng dụng Word đã sử dụng thư viện PDF REFLOW dư sức để chuyển đổi PDF ưu việt.
Và PDF là một file được Scan thì thêm giải pháp khác là ứng dụng ABBYY FINEREADER, chuyển đổi Hình ảnh sang cấu trúc dữ liệu số.

Dựa trên các cơ sở Code ở trên và phương thức chuyển đổi từ xpdf, code dưới đây sẽ tự động hóa hoàn toàn, mà không phải qua bước Download thủ công.

JavaScript:
Option Explicit
#Const EarlyBinding = False
Public Const DicsPDF = "\FilesPDF\"
#If VBA7 Then
  Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
  (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
  ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#Else
  Private Declare  Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
  (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
  ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If

Private Sub test_PDF2TXT_xPDF()
  Dim Arr, sPath$
  sPath = Environ$("USERPROFILE") & DicsPDF
  ListAllFiles sPath, FSO, Arr, False, ".pdf", , False, False
  PDF2TXT_xPDF Arr
End Sub


Sub PDF2TXT_xPDF(Arr, _
  Optional ByVal first_page As Long = 0, _
  Optional ByVal last_page As Long = 0, _
  Optional ByVal method As String = "raw", _
  Optional ByVal encode As String = "UTF-8", _
  Optional ByVal page_break As Boolean = False, _
  Optional ByVal password As String = "")
  Dim pdfEXE$
  pdfEXE = EXE_xPDF & "pdftotext.exe"
  Dim wShell As Object, comm$, K%, FileName$
  Set wShell = CreateObject("WScript.Shell")
  If first_page > 0 And first_page <= last_page Then comm = "-f " & first_page & " -l " & last_page & " "
  If method <> "" Then comm = comm & "-" & method & " "
  If encode = "" Then encode = "UTF-8"
  comm = comm & "-enc " & encode & " "
  If Not page_break Then comm = comm & "-nopgbrk "
  If password <> "" Then comm = comm & "-opw " & password & " "
  comm = Chr(34) & pdfEXE & Chr(34) & " " & comm
  For K = LBound(Arr) To UBound(Arr)
    'Dùng CountPagesPDF(Arr(K)) để giới hạn số Trang'
    FileName = Left(Arr(K), InStrRev(Arr(K), ".") - 1) & "_" & Format(Now, "ddmmyyyyhhmmss") & ".txt"
    wShell.Run comm & Chr(34) & Arr(K) & Chr(34) & Chr(32) & Chr(34) & FileName & Chr(34), 0, -1
  Next K
  Set wShell = Nothing
End Sub


Function CountPagesPDF&(ByVal FullPath$)
  On Error Resume Next
  #If EarlyBinding Then
    Dim RegExp As RegExp
    Set RegExp = New RegExp
  #Else
    Dim RegExp As Object
    #If Win64 Then
      Set RegExp = CreateObject("VBscript.RegExp.5.5")
    #Else
      Set RegExp = CreateObject("VBscript.RegExp")
    #End If
  #End If
  Dim xFileNum&, xStr$
  RegExp.Global = True
  RegExp.Pattern = "/Type\s*/Page[^s]"
  xFileNum = FreeFile
  Open (FullPath) For Binary As #xFileNum
      xStr = Space(LOF(xFileNum))
      Get #xFileNum, , xStr
  Close #xFileNum
  CountPagesPDF = RegExp.Execute(xStr).Count
  Set RegExp = Nothing
End Function


Function EXE_xPDF() As String
  #If Mac Then
    Exit Function
  #End If
  Const p_xPDF = "http://www.xpdfreader.com/download.html"
  Dim Temp$, dURL$, Doc, nFile$, fFile$, fFolder$, Ext$, Name$, L%
  Temp = IIf(Environ$("Tmp") <> "", Environ$("Tmp"), Environ$("Temp")) & Application.PathSeparator

  #If EarlyBinding Then
    Dim FSO As Scripting.FileSystemObject
    Set FSO = New Scripting.FileSystemObject
  #Else
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
  #End If
  Dim Sh As Object
  Set Sh = CreateObject("Shell.Application")
  Dim Item, sFolder

  Set sFolder = FSO.GetFolder(Temp)

  #If Win64 Then
      Const bin = "bin64\"
  #Else
      Const bin = "bin32\"
  #End If
  For Each Item In sFolder.SubFolders
    If LCase$(Item.Path) Like "*xpdf*win*" Then
      EXE_xPDF = Item.Path & Application.PathSeparator & bin: Exit Function
    End If
  Next Item
  Set Doc = HTMLResponse(p_xPDF)
  If Doc Is Nothing Then Exit Function
  Dim Li
  For Each Li In Doc.getElementsByTagName("li")
    If LCase$(Li.innerText) Like "*window*32/64*bit*" Then
      dURL = Li.getElementsByTagName("a")(0).getAttribute("href")
      Exit For
    End If
  Next
  If Not dURL Like "*/*" Then Exit Function
  L = InStrRev(dURL, "/")
  nFile = Right$(dURL, Len(dURL) - L)
  L = InStrRev(nFile, ".")
  Name = Left$(nFile, L - 1)
  Ext = Right$(nFile, Len(nFile) - L)
  fFile = Temp & nFile
  fFolder = Temp & Name: L = 0
  If Not FSO.FolderExists(fFolder) Then
    On Error Resume Next
      If Not FSO.FileExists(fFile) Then
        If URLDownloadToFile(0, dURL, fFile, 0, 0) = 0 Then
          Do Until FSO.FileExists(fFile)
            Application.Wait Now + TimeSerial(0, 0, 1)
            L = L + 1: If L > 20 Then Exit Do
            DoEvents
          Loop
        End If
      End If
      Application.Wait Now + TimeSerial(0, 0, 1)
      With Sh
        .Namespace(CVar(Temp)).CopyHere .Namespace(CVar(fFile)).items, &H10&
      End With
      FSO.DeleteFile fFile, True
    On Error GoTo 0
  End If
  EXE_xPDF = fFolder & Application.PathSeparator & bin
  Set FSO = Nothing: Set Sh = Nothing
End Function

Function HTMLResponse(Url$) As Object
  On Error Resume Next
    Dim oHttp As Object, Doc As Object
    Set Doc = CreateObject("HTMLFile")
    #If Win64 Then
      Set oHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    #Else
      Set oHttp = CreateObject("MSXML2.ServerXMLHTTP")
    #End If

  With oHttp
    .Open "GET", Url, False
    .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/74.0.3729.131 Safari/537.36"
    .setRequestHeader "Content-type", "application/x-www-form-urlencoded"
    .Send ""
    If .Status = 200 Then
      Doc.body.innerHTML = .responseText
      Set HTMLResponse = Doc
    End If
    Set Doc = Nothing
  End With
  Set oHttp = Nothing
End Function
Chuyên gia viết code xong ko chạy thử ... thiếu cái Hàm To trà bá Luôn: ListAllFiles
hay nó ở Module khác he
 
Upvote 0
Và PDF là một file được Scan thì thêm giải pháp khác là ứng dụng ABBYY FINEREADER, chuyển đổi Hình ảnh sang cấu trúc dữ liệu số.
Nếu chất lượng PDF không thật chuẩn thì ABBYY FINEREADER cũng khóc và bó tay ngay cả với văn bản tiếng Anh, chưa nói tới tiếng Việt.
 
Upvote 0
Nếu chất lượng PDF không thật chuẩn thì ABBYY FINEREADER cũng khóc và bó tay ngay cả với văn bản tiếng Anh, chưa nói tới tiếng Việt.
Ý của Bác chắc là phải dùng đến AI của Google Vision and Orc. Nếu file không đủ chất lượng thì đòi hỏi công nghệ cao, cũng phải vung tiền bù đắp sự kém cõi

Chuyên gia viết code xong ko chạy thử ... thiếu cái Hàm To trà bá Luôn: ListAllFiles
hay nó ở Module khác he
Nếu bác bỏ thủ tục đó cũng test được.
 
Upvote 0
Ý của Bác chắc là phải dùng đến AI của Google Vision and Orc. Nếu file không đủ chất lượng thì đòi hỏi công nghệ cao, cũng phải vung tiền bù đắp sự kém cõi
Tôi nói rõ thôi. Kẻo nhiều người cứ tưởng ảnh nào vào cũng có kết quả. Tức kết quả có nhưng tự đọc PDF rồi gõ nhiều khi còn nhanh hơn.
 
Upvote 0
thiếu cái Hàm To trà bá Luôn: ListAllFiles
hay nó ở Module khác he

Thủ tục ListAllFiles

Tuy nhiên, em có một mong muốn mong thầy giúp đỡ
Đó là sử dụng file của thấy để 1 lần có thể đọc được hết toàn bộ tệp tin pdf trong 1 thư mục
Do file của thầy 1 lần chỉ đọc 1 file mà trong thư mục của em có khoảng mấy chục file

Bạn dựa vào thủ tục trên để thực hiện
 
Lần chỉnh sửa cuối:
Upvote 0

Có nhiều cách đọc tập tin pdf, ở đây tôi xin giới thiệu cách đọc tập tin pdf sử dụng công cụ xpdfreader.
http://www.xpdfreader.com/download.html
Trong ví dụ sau tôi sử dụng pdftotext (tức là chuyển pdf sang tập tin text) và sau đó sẽ đưa vào Excel.
1, Đầu tiên các bạn theo link trên tải về, giải nén và copy tập tin pdftotext.exe vào thư mục có chứa tập tin pdf muốn đọc.
2, Thay đổi các thông số ở sheet Setting trong tập tin Excel tôi upload lên cho phù hợp với yêu cầu của mình.
3, Thử chạy bằng việc nhấn vào nút Lấy dữ liệu cũng trong sheet Setting. Kết quả sẽ đưa vào sheet Result.

Code sau:
Rich (BB code):
'---------------------------------------------------------------------------------------
' Method : MoFilePdf
' Author : Doit
' Date   : 07/04/2019
' Purpose: Nham doc file pdf va dua vao Excel
'
'          Tai pdftotext tai http://www.xpdfreader.com/download.html
'          Tham khao tai lieu tai http://www.xpdfreader.com/pdftotext-man.html
'---------------------------------------------------------------------------------------
Sub MoFilePdf()

    Dim sFolderPath As String, sBatFileName As String, sPdfFileName As String, sTxtFileNamePath As String
    Dim sPdfExeFolder As String, sTxtFileName As String, FileNumber As Integer, sData As String
    Dim lRow As Long
    Dim PID As Variant
    Dim wsSetting As Worksheet, wsResult As Worksheet

    On Error GoTo MoFilePdf_Error

    ' Nham tang toc do thuc hien
    Application.EnableEvents = False    'Disable Excel Events
    Application.ScreenUpdating = False    'Turn Off Screen Updating to eliminate Screen Flicker and to improve speed performance

    ' Lay ten cac tap tin
    '=====================
    Set wsSetting = ThisWorkbook.Worksheets("Setting")
    Set wsResult = ThisWorkbook.Worksheets("Result")
    sFolderPath = wsSetting.Range("E2")
    sPdfFileName = wsSetting.Range("E3")
    sBatFileName = wsSetting.Range("E4")
    sTxtFileName = wsSetting.Range("E5")
    sTxtFileNamePath = sFolderPath & "\" & sTxtFileName
    sPdfExeFolder = wsSetting.Range("E6")

    ' Tao tap tin bat
    '=================
    FileNumber = FreeFile
    Open sBatFileName For Output As #FileNumber
    ' Chuyen ve thu muc tap tin pdftotext.exe
    Print #FileNumber, "cd " & sPdfExeFolder
    ' Lenh ke tiep cho chay chuong trinh pdftotext.exe voi cac tham so thiet lap truoc
    ' Chu y: su dung Chr(34) cho dau ngoac kep
    Print #FileNumber, "pdftotext.exe -layout " & Chr(34) & sPdfFileName & Chr(34) & " " & Chr(34) & sTxtFileName & Chr(34)
    ' Lenh ke tiep la thoat
    Print #FileNumber, "exit"
    Close #FileNumber

    ' Thuc thi batFile
    ' ================
    PID = Shell(sBatFileName, vbNormalFocus)
    If Err.Number <> 0 Then
        ' Neu co loi thi di den bay loi va thong bao
        GoTo MoFilePdf_Error
    End If
    ' Tiep tuc dua du lieu ra sheet Result
    ' =====================================
    FileNumber = FreeFile
    ' Hang dau de xuat du lieu
    lRow = 1
    wsResult.Cells.Clear    ' Xoa du lieu truoc khi xuat ra
    Open sTxtFileNamePath For Input As FileNumber
    Do While Not EOF(FileNumber)
        Line Input #FileNumber, sData
        wsResult.Cells(lRow, 1) = sData
        lRow = lRow + 1
    Loop
    Close #FileNumber

    ' Neu thanh cong thi thong bao
    MsgBox "Ban da lay du lieu tu tap tin pdf thanh cong.", vbOKOnly, "Thong bao"

MoFilePdf_Exit:
    ' Giai phong bien/release memory
    Set wsSetting = Nothing
    Set wsResult = Nothing

    ' Tra lai tinh trang ban dau
    Application.EnableEvents = True    'Enable Excel Events
    Application.ScreenUpdating = True    'Enable Screen Updating
    Exit Sub

MoFilePdf_Error:
    ' vbCrLf la ky tu xuong dong
    MsgBox "Loi " & Err.Number & " (" & Err.Description & ")." & vbCrLf & "Vui long kiem tra lai.", vbOKOnly + vbInformation, "Thong bao"

End Sub

Trong code ở trên tôi có giải thích.

Hy vọng đây cũng là một ví dụ tham khảo giúp ích cho các bạn.

Lê Văn Duyệt

Bác ơi lỗi này sửa thế nào nhỉ?
Khi chọn OK thì vào vẫn thấy đã lấy dữ liệu sang file text rồi ạ

1573124437521.png
 
Upvote 0
An
Bác Duyệt chỉ đưa ra một giải pháp tạm thời.
Tuy nhiên từ Office 2013 cho đến thời điểm hiện tại trong ứng dụng Word đã sử dụng thư viện PDF REFLOW dư sức để chuyển đổi PDF ưu việt.
Và PDF là một file được Scan thì thêm giải pháp khác là ứng dụng ABBYY FINEREADER, chuyển đổi Hình ảnh sang cấu trúc dữ liệu số.

Dựa trên các cơ sở Code ở trên và phương thức chuyển đổi từ xpdf, code dưới đây sẽ tự động hóa hoàn toàn, mà không phải qua bước Download thủ công.

Thủ tục ListAllFiles

JavaScript:
Option Explicit
#Const EarlyBinding = False
Public Const DicsPDF = "\FilesPDF\"
#If VBA7 Then
  Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
  (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
  ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#Else
  Private Declare  Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
  (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
  ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If

Private Sub test_PDF2TXT_xPDF()
  Dim Arr
  Arr = Array("*1.pdf", "*2.pdf")
  'Tham khảo hàm ListAllFiles
  'ListAllFiles "D:\", , Arr, True, ".pdf"
  PDF2TXT_xPDF Arr
End Sub


Sub PDF2TXT_xPDF(Arr, _
  Optional ByVal first_page As Long = 0, _
  Optional ByVal last_page As Long = 0, _
  Optional ByVal method As String = "raw", _
  Optional ByVal encode As String = "UTF-8", _
  Optional ByVal page_break As Boolean = False, _
  Optional ByVal password As String = "")
  Dim pdfEXE$
  pdfEXE = EXE_xPDF & "pdftotext.exe"
  Dim wShell As Object, comm$, K%, FileName$
  Set wShell = CreateObject("WScript.Shell")
  If first_page > 0 And first_page <= last_page Then comm = "-f " & first_page & " -l " & last_page & " "
  If method <> "" Then comm = comm & "-" & method & " "
  If encode = "" Then encode = "UTF-8"
  comm = comm & "-enc " & encode & " "
  If Not page_break Then comm = comm & "-nopgbrk "
  If password <> "" Then comm = comm & "-opw " & password & " "
  comm = Chr(34) & pdfEXE & Chr(34) & " " & comm
  For K = LBound(Arr) To UBound(Arr)
    'Dùng CountPagesPDF(Arr(K)) để giới hạn số Trang'
    FileName = Left(Arr(K), InStrRev(Arr(K), ".") - 1) & "_" & Format(Now, "ddmmyyyyhhmmss") & ".txt"
    wShell.Run comm & Chr(34) & Arr(K) & Chr(34) & Chr(32) & Chr(34) & FileName & Chr(34), 0, -1
  Next K
  Set wShell = Nothing
End Sub


Function CountPagesPDF&(ByVal FullPath$)
  On Error Resume Next
  #If EarlyBinding Then
    Dim RegExp As RegExp
    Set RegExp = New RegExp
  #Else
    Dim RegExp As Object
    #If Win64 Then
      Set RegExp = CreateObject("VBscript.RegExp.5.5")
    #Else
      Set RegExp = CreateObject("VBscript.RegExp")
    #End If
  #End If
  Dim xFileNum&, xStr$
  RegExp.Global = True
  RegExp.Pattern = "/Type\s*/Page[^s]"
  xFileNum = FreeFile
  Open (FullPath) For Binary As #xFileNum
      xStr = Space(LOF(xFileNum))
      Get #xFileNum, , xStr
  Close #xFileNum
  CountPagesPDF = RegExp.Execute(xStr).Count
  Set RegExp = Nothing
End Function


Function EXE_xPDF() As String
  #If Mac Then
    Exit Function
  #End If
  Const p_xPDF = "http://www.xpdfreader.com/download.html"
  Dim Temp$, dURL$, Doc, nFile$, fFile$, fFolder$, Ext$, Name$, L%
  Temp = IIf(Environ$("Tmp") <> "", Environ$("Tmp"), Environ$("Temp")) & Application.PathSeparator

  #If EarlyBinding Then
    Dim FSO As Scripting.FileSystemObject
    Set FSO = New Scripting.FileSystemObject
  #Else
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
  #End If
  Dim Sh As Object
  Set Sh = CreateObject("Shell.Application")
  Dim Item, sFolder

  Set sFolder = FSO.GetFolder(Temp)

  #If Win64 Then
      Const bin = "bin64\"
  #Else
      Const bin = "bin32\"
  #End If
  For Each Item In sFolder.SubFolders
    If LCase$(Item.Path) Like "*xpdf*win*" Then
      EXE_xPDF = Item.Path & Application.PathSeparator & bin: Exit Function
    End If
  Next Item
  Set Doc = HTMLResponse(p_xPDF)
  If Doc Is Nothing Then Exit Function
  Dim Li
  For Each Li In Doc.getElementsByTagName("li")
    If LCase$(Li.innerText) Like "*window*32/64*bit*" Then
      dURL = Li.getElementsByTagName("a")(0).getAttribute("href")
      Exit For
    End If
  Next
  If Not dURL Like "*/*" Then Exit Function
  L = InStrRev(dURL, "/")
  nFile = Right$(dURL, Len(dURL) - L)
  L = InStrRev(nFile, ".")
  Name = Left$(nFile, L - 1)
  Ext = Right$(nFile, Len(nFile) - L)
  fFile = Temp & nFile
  fFolder = Temp & Name: L = 0
  If Not FSO.FolderExists(fFolder) Then
    On Error Resume Next
      If Not FSO.FileExists(fFile) Then
        If URLDownloadToFile(0, dURL, fFile, 0, 0) = 0 Then
          Do Until FSO.FileExists(fFile)
            Application.Wait Now + TimeSerial(0, 0, 1)
            L = L + 1: If L > 20 Then Exit Do
            DoEvents
          Loop
        End If
      End If
      Application.Wait Now + TimeSerial(0, 0, 1)
      With Sh
        .Namespace(CVar(Temp)).CopyHere .Namespace(CVar(fFile)).items, &H10&
      End With
      FSO.DeleteFile fFile, True
    On Error GoTo 0
  End If
  EXE_xPDF = fFolder & Application.PathSeparator & bin
  Set FSO = Nothing: Set Sh = Nothing
End Function

Function HTMLResponse(Url$) As Object
  On Error Resume Next
    Dim oHttp As Object, Doc As Object
    Set Doc = CreateObject("HTMLFile")
    #If Win64 Then
      Set oHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    #Else
      Set oHttp = CreateObject("MSXML2.ServerXMLHTTP")
    #End If

  With oHttp
    .Open "GET", Url, False
    .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/74.0.3729.131 Safari/537.36"
    .setRequestHeader "Content-type", "application/x-www-form-urlencoded"
    .Send ""
    If .Status = 200 Then
      Doc.body.innerHTML = .responseText
      Set HTMLResponse = Doc
    End If
    Set Doc = Nothing
  End With
  Set oHttp = Nothing
End Function

Anh hướng dẫn chi tiết thêm được không ạ?
Thanks anh!
 
Upvote 0
Bác Duyệt chỉ đưa ra một giải pháp tạm thời.
Tuy nhiên từ Office 2013 cho đến thời điểm hiện tại trong ứng dụng Word đã sử dụng thư viện PDF REFLOW dư sức để chuyển đổi PDF ưu việt.
Và PDF là một file được Scan thì thêm giải pháp khác là ứng dụng ABBYY FINEREADER, chuyển đổi Hình ảnh sang cấu trúc dữ liệu số.

Dựa trên các cơ sở Code ở trên và phương thức chuyển đổi từ xpdf, code dưới đây sẽ tự động hóa hoàn toàn, mà không phải qua bước Download thủ công.

Thủ tục ListAllFiles

JavaScript:
Option Explicit
#Const EarlyBinding = False
Public Const DicsPDF = "\FilesPDF\"
#If VBA7 Then
  Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
  (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
  ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#Else
  Private Declare  Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
  (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
  ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If

Private Sub test_PDF2TXT_xPDF()
  Dim Arr
  Arr = Array("*1.pdf", "*2.pdf")
  'Tham khảo hàm ListAllFiles
  'ListAllFiles "D:\", , Arr, True, ".pdf"
  PDF2TXT_xPDF Arr
End Sub


Sub PDF2TXT_xPDF(Arr, _
  Optional ByVal first_page As Long = 0, _
  Optional ByVal last_page As Long = 0, _
  Optional ByVal method As String = "raw", _
  Optional ByVal encode As String = "UTF-8", _
  Optional ByVal page_break As Boolean = False, _
  Optional ByVal password As String = "")
  Dim pdfEXE$
  pdfEXE = EXE_xPDF & "pdftotext.exe"
  Dim wShell As Object, comm$, K%, FileName$
  Set wShell = CreateObject("WScript.Shell")
  If first_page > 0 And first_page <= last_page Then comm = "-f " & first_page & " -l " & last_page & " "
  If method <> "" Then comm = comm & "-" & method & " "
  If encode = "" Then encode = "UTF-8"
  comm = comm & "-enc " & encode & " "
  If Not page_break Then comm = comm & "-nopgbrk "
  If password <> "" Then comm = comm & "-opw " & password & " "
  comm = Chr(34) & pdfEXE & Chr(34) & " " & comm
  For K = LBound(Arr) To UBound(Arr)
    'Dùng CountPagesPDF(Arr(K)) để giới hạn số Trang'
    FileName = Left(Arr(K), InStrRev(Arr(K), ".") - 1) & "_" & Format(Now, "ddmmyyyyhhmmss") & ".txt"
    wShell.Run comm & Chr(34) & Arr(K) & Chr(34) & Chr(32) & Chr(34) & FileName & Chr(34), 0, -1
  Next K
  Set wShell = Nothing
End Sub


Function CountPagesPDF&(ByVal FullPath$)
  On Error Resume Next
  #If EarlyBinding Then
    Dim RegExp As RegExp
    Set RegExp = New RegExp
  #Else
    Dim RegExp As Object
    #If Win64 Then
      Set RegExp = CreateObject("VBscript.RegExp.5.5")
    #Else
      Set RegExp = CreateObject("VBscript.RegExp")
    #End If
  #End If
  Dim xFileNum&, xStr$
  RegExp.Global = True
  RegExp.Pattern = "/Type\s*/Page[^s]"
  xFileNum = FreeFile
  Open (FullPath) For Binary As #xFileNum
      xStr = Space(LOF(xFileNum))
      Get #xFileNum, , xStr
  Close #xFileNum
  CountPagesPDF = RegExp.Execute(xStr).Count
  Set RegExp = Nothing
End Function


Function EXE_xPDF() As String
  #If Mac Then
    Exit Function
  #End If
  Const p_xPDF = "http://www.xpdfreader.com/download.html"
  Dim Temp$, dURL$, Doc, nFile$, fFile$, fFolder$, Ext$, Name$, L%
  Temp = IIf(Environ$("Tmp") <> "", Environ$("Tmp"), Environ$("Temp")) & Application.PathSeparator

  #If EarlyBinding Then
    Dim FSO As Scripting.FileSystemObject
    Set FSO = New Scripting.FileSystemObject
  #Else
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
  #End If
  Dim Sh As Object
  Set Sh = CreateObject("Shell.Application")
  Dim Item, sFolder

  Set sFolder = FSO.GetFolder(Temp)

  #If Win64 Then
      Const bin = "bin64\"
  #Else
      Const bin = "bin32\"
  #End If
  For Each Item In sFolder.SubFolders
    If LCase$(Item.Path) Like "*xpdf*win*" Then
      EXE_xPDF = Item.Path & Application.PathSeparator & bin: Exit Function
    End If
  Next Item
  Set Doc = HTMLResponse(p_xPDF)
  If Doc Is Nothing Then Exit Function
  Dim Li
  For Each Li In Doc.getElementsByTagName("li")
    If LCase$(Li.innerText) Like "*window*32/64*bit*" Then
      dURL = Li.getElementsByTagName("a")(0).getAttribute("href")
      Exit For
    End If
  Next
  If Not dURL Like "*/*" Then Exit Function
  L = InStrRev(dURL, "/")
  nFile = Right$(dURL, Len(dURL) - L)
  L = InStrRev(nFile, ".")
  Name = Left$(nFile, L - 1)
  Ext = Right$(nFile, Len(nFile) - L)
  fFile = Temp & nFile
  fFolder = Temp & Name: L = 0
  If Not FSO.FolderExists(fFolder) Then
    On Error Resume Next
      If Not FSO.FileExists(fFile) Then
        If URLDownloadToFile(0, dURL, fFile, 0, 0) = 0 Then
          Do Until FSO.FileExists(fFile)
            Application.Wait Now + TimeSerial(0, 0, 1)
            L = L + 1: If L > 20 Then Exit Do
            DoEvents
          Loop
        End If
      End If
      Application.Wait Now + TimeSerial(0, 0, 1)
      With Sh
        .Namespace(CVar(Temp)).CopyHere .Namespace(CVar(fFile)).items, &H10&
      End With
      FSO.DeleteFile fFile, True
    On Error GoTo 0
  End If
  EXE_xPDF = fFolder & Application.PathSeparator & bin
  Set FSO = Nothing: Set Sh = Nothing
End Function

Function HTMLResponse(Url$) As Object
  On Error Resume Next
    Dim oHttp As Object, Doc As Object
    Set Doc = CreateObject("HTMLFile")
    #If Win64 Then
      Set oHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    #Else
      Set oHttp = CreateObject("MSXML2.ServerXMLHTTP")
    #End If

  With oHttp
    .Open "GET", Url, False
    .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/74.0.3729.131 Safari/537.36"
    .setRequestHeader "Content-type", "application/x-www-form-urlencoded"
    .Send ""
    If .Status = 200 Then
      Doc.body.innerHTML = .responseText
      Set HTMLResponse = Doc
    End If
    Set Doc = Nothing
  End With
  Set oHttp = Nothing
End Function
Em chào anh,
Em đã chạy thử và bị báo lỗi ở chỗ này:
wShell.Run comm & Chr(34) & Arr(K) & Chr(34) & Chr(32) & Chr(34) & FileName & Chr(34), 0, -1
Và thông báo lỗi hiện lên như vậy: Run-time error -2147024894(80070002)': Method Run' of object lWshShell3 ' failed
Cũng với file đó em chạy thử trên 1 máy khác thì lại không bị, kết quả rất tốt. Loay hoay mãi mà vẫn chưa tìm ra được nguyên nhân, nhờ anh xem giúp em liệu lỗi có thể ở đâu vậy ạ.

1680681385686.png1680681412418.png
 
Upvote 1
Web KT
Back
Top Bottom