Đọc tập tin pdf và đưa vào Excel (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

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,707
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

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
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 ạ.

View attachment 288488View attachment 288489
Mình copy code nhưng nhìn mãi k biết chạy như nào, lấy đường dẫn đến thư mục chứa các file pdf cần convert sao, Bạn chỉ giúp mình với
 
Upvote 0
Mình copy code nhưng nhìn mãi k biết chạy như nào, lấy đường dẫn đến thư mục chứa các file pdf cần convert sao, Bạn chỉ giúp mình với
Bạn thay đường dẫn các file PDF vào chỗ 1 2....... bên dưới, để sử dụng hiệu quả thì bạn phải xào chế code thêm 1 xíu.

Private Sub test_PDF2TXT_xPDF()
Dim Arr
Arr = Array("*1.pdf", "*2.pdf")
PDF2TXT_xPDF Arr
End Sub
 
Upvote 0
mình hỏi chút, code lúc bấm run thì k thấy code nào trong bảng run
b có thể giúp m sửa những chỗ nào k
code tổng quát quá nên mình cũng k biết sửa sao
 
Upvote 0
mình hỏi chút, code lúc bấm run thì k thấy code nào trong bảng run
b có thể giúp m sửa những chỗ nào k
code tổng quát quá nên mình cũng k biết sửa sao
Bạn thay dường dẫn vào rồi chạy cái sub này là được nè, mình cũng chỉ là sơ nhập VBA nên cũng đang bế tắc với vụ lỗi gặp phải, đang thử rẽ sang các hướng khác để tìm, hiện tại có rất nhiều website và phần mềm chuyển PDF sang TXT, bạn gõ google là có. Nếu không rành về VBA lắm thì tốt hơn nên đi vòng 1 xíu cũng được bạn ạ, vì muốn sử dụng hiệu quả code này bạn cũng phải biết chút ít VBA để chế thêm.

Private Sub test_PDF2TXT_xPDF()
Dim Arr
Arr = Array("*1.pdf", "*2.pdf")
PDF2TXT_xPDF Arr
End Sub
 
Upvote 0
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 ạ.

View attachment 288488View attachment 288489
Tôi đã giải quyết được vấn đề của mình, chia sẻ cho bạn nào có gặp phải lỗi như tôi:
Nhấn tổ hợp phím Windows + R, gõ %temp%
Tìm thư mục Xpdf, nó sẽ có tên tương tự như xpdf-win-4.04, xóa luôn cả thư mục này.
Chạy lại code là được, khi chạy code sẽ tự cài đặt lại xpdf, có thể tôi bị lỗi chỗ cài đặt này trước đó nên máy tôi không chạy được code.
 
Upvote 0
Tôi đã giải quyết được vấn đề của mình, chia sẻ cho bạn nào có gặp phải lỗi như tôi:
Nhấn tổ hợp phím Windows + R, gõ %temp%
Tìm thư mục Xpdf, nó sẽ có tên tương tự như xpdf-win-4.04, xóa luôn cả thư mục này.
Chạy lại code là được, khi chạy code sẽ tự cài đặt lại xpdf, có thể tôi bị lỗi chỗ cài đặt này trước đó nên máy tôi không chạy được code.
Bác chạy được code của anh HeSanbi rồi ạ ?
 
Upvote 0
Vâng, code chạy tốt mà bạn, mình đã sử dụng nhiều code khác để chạy thử nhưng cuối cùng vẫn sử dụng mã code này, vì định dạng đầu ra rất phù hợp ý mình.
Code của anh HeSanbi cũng copy vào file macro của bác levanduyet phải không bạn
Khi copy code vào, bạn có thấy bị báo những dòng đỏ này k ạ ?
Bạn có thể cho mình xin liên lạc được không bạn, cám ơn bạn nhiều
1681265199740.png
 

File đính kèm

  • 1681265103369.png
    1681265103369.png
    145.1 KB · Đọc: 7
Upvote 0
Code của anh HeSanbi cũng copy vào file macro của bác levanduyet phải không bạn
Khi copy code vào, bạn có thấy bị báo những dòng đỏ này k ạ ?
Bạn có thể cho mình xin liên lạc được không bạn, cám ơn bạn nhiều
View attachment 288822
Khi copy code vào, bạn có thấy bị báo những dòng đỏ này k ạ ? -> Có nha bạn
Bạn lưu ý là code của anh Hesanbi hoặc anh Batman1 chỉ chuyển từ file PDF sang TXT, còn muốn chuyển vào file Excel thì bạn phải xào nấu thêm tùy nhu cầu của bạn.
Dưới đây là đoạn code củ chuối của mình, bạn copy vào, thay thế hoàn toàn Sub test_PDF2TXT_xPDF() cũ, sau đó chạy Sub test_PDF2TXT_xPDF() vừa mới paste vào, lúc này bạn có thể chọn một hoặc nhiều file PDF cần chuyển sang TXT. Sau đó hãy kiểm tra lại kết quả, sẽ có các file TXT mới tạo ra tương ứng với các file PDF được chọn trong cùng thư mục.

Mã:
Sub test_PDF2TXT_xPDF()
    Dim i As Integer
    Dim FilePaths As Variant
    Dim StrPaths As String
    FilePaths = Application.GetOpenFilename(filefilter:="PDF Files (*.pdf), *.pdf", MultiSelect:=True)
    If VarType(FilePaths) = vbBoolean Then Exit Sub
    For i = LBound(FilePaths) To UBound(FilePaths)
        StrPaths = StrPaths & Chr(34) & FilePaths(i) & Chr(34) & "|"
    Next i
    StrPaths = LEFT(StrPaths, Len(StrPaths) - 1)
    Dim Arr
    Arr = Split(StrPaths, "|")
    PDF2TXT_xPDF Arr
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Khi copy code vào, bạn có thấy bị báo những dòng đỏ này k ạ ? -> Có nha bạn
Bạn lưu ý là code của anh Hesanbi hoặc anh Batman1 chỉ chuyển từ file PDF sang TXT, còn muốn chuyển vào file Excel thì bạn phải xào nấu thêm tùy nhu cầu của bạn.
Dưới đây là đoạn code củ chuối của mình, bạn copy vào, thay thế hoàn toàn Sub test_PDF2TXT_xPDF() cũ, sau đó chạy Sub test_PDF2TXT_xPDF() vừa mới paste vào, lúc này bạn có thể chọn một hoặc nhiều file PDF cần chuyển sang TXT. Sau đó hãy kiểm tra lại kết quả, sẽ có các file TXT mới tạo ra tương ứng với các file PDF được chọn trong cùng thư mục.

Mã:
Sub test_PDF2TXT_xPDF()
    Dim i As Integer
    Dim FilePaths As Variant
    Dim StrPaths As String
    FilePaths = Application.GetOpenFilename(filefilter:="PDF Files (*.pdf), *.pdf", MultiSelect:=True)
    If VarType(FilePaths) = vbBoolean Then Exit Sub
    For i = LBound(FilePaths) To UBound(FilePaths)
        StrPaths = StrPaths & Chr(34) & FilePaths(i) & Chr(34) & "|"
    Next i
    StrPaths = LEFT(StrPaths, Len(StrPaths) - 1)
    Dim Arr
    Arr = Split(StrPaths, "|")
    PDF2TXT_xPDF Arr
End Sub
Cám ơn bác, em sửa phần code bác HeSanbi theo hướng dẫn ok rồi, file đã cho chạy chọn nhiều file PDF, và cũng bị lỗi như của bác, em thực hiện xóa trong temp như bác bảo rồi
Tuy nhiên chạy xong file bị Kaspersky quét virus xóa đi luôn :((

Để em thử mò qua code của bác Batman1 xem sao

"..
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"
1681280423464.png
 
Upvote 0
Cám ơn bác, em sửa phần code bác HeSanbi theo hướng dẫn ok rồi, file đã cho chạy chọn nhiều file PDF, và cũng bị lỗi như của bác, em thực hiện xóa trong temp như bác bảo rồi
Tuy nhiên chạy xong file bị Kaspersky quét virus xóa đi luôn :((

Để em thử mò qua code của bác Batman1 xem sao

"..
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"
View attachment 288852
Run-time error -2147024894(80070002) đó có thể là bạn không có đủ quyền để chạy. Bạn thử chuyển file pdf sang thư mục mới tạo ở ổ D xem.
 
Upvote 0
Run-time error -2147024894(80070002) đó có thể là bạn không có đủ quyền để chạy. Bạn thử chuyển file pdf sang thư mục mới tạo ở ổ D xem.

Em copy nhặt thêm code cho chọn nhiều file PDF đưa vào code của bác batman1, giờ chạy OK ra được nhiều file text, với đầy đủ dấu tiếng Việt rồi bác ạ

Các huynh có code nào chọn các file text này, đưa vào chỉ định cột F copy lần lượt nối tiếp vào giúp em với ạ

P/S: Em cũng đang dùng 1 code chạy copy text của pdf vào excel, nó hoạt động kiểu mở file pdf lên, copy nội dung, dán text vào file excel chỉ định tại 1 cột. Tuy nhiên việc bộ nhớ clip broad nó cứ bị trùng sau mỗi vòng, nên hay bị thiếu file hoặc trùng file text. Nên em thấy cách sử dụng ứng dụng pdftotext.exe theo cách của anh levanduyet và của anh batman1 sẽ không bị lỗi bộ nhớ clipboard copy

Sub Copy_HNX_PDF_multi()

Dim App_Path As String
Dim Pdf_path As Variant
Dim shell_path As String
Dim i As Variant
Dim lastrow As Long

Set MyWorksheet = ActiveWorkbook.Worksheets("TD.hnx+")
App_Path = "C:\Program Files (x86)\Adobe\Reader 9.0\Reader\AcroRd32.exe"
Pdf_path = Application.GetOpenFilename("Pdf Files (*.pdf), *.pdf", , "Select Statements", , True)

For i = LBound(Pdf_path) To UBound(Pdf_path)

shell_path = App_Path & " """ & Pdf_path(i) & """"
Call Shell(pathname:=shell_path, windowstyle:=vbNormalFocus)

Application.Wait Now + TimeValue("0:00:03")

SendKeys "%vpc"
SendKeys "^a"
SendKeys "^c"

With MyWorksheet
lastrow = .Cells(.Rows.Count, "F").End(xlUp).Row
End With

Range("F" & lastrow + 2).Select
ActiveWorkbook.Worksheets("TD.hnx+").PasteSpecial Format:="Unicode Text"
Application.CutCopyMode = False

Next i

With MyWorksheet
.Range("G6:AD6").Copy Destination:=.Range("G7:AD" & [F100000].End(xlUp).Row)
Application.CutCopyMode = False
End With

Call Shell("TaskKill /F /IM AcroRd32.exe", vbHide)

MsgBox "Hoàn Thành"

End Sub


1681284027916.png1681283210086.png1681284108364.png
P
 

File đính kèm

Upvote 0
Em copy nhặt thêm code cho chọn nhiều file PDF đưa vào code của bác batman1, giờ chạy OK ra được nhiều file text, với đầy đủ dấu tiếng Việt rồi bác ạ

Các huynh có code nào chọn các file text này, đưa vào chỉ định cột F copy lần lượt nối tiếp vào giúp em với ạ

P/S: Em cũng đang dùng 1 code chạy copy text của pdf vào excel, nó hoạt động kiểu mở file pdf lên, copy nội dung, dán text vào file excel chỉ định tại 1 cột. Tuy nhiên việc bộ nhớ clip broad nó cứ bị trùng sau mỗi vòng, nên hay bị thiếu file hoặc trùng file text. Nên em thấy cách sử dụng ứng dụng pdftotext.exe theo cách của anh levanduyet và của anh batman1 sẽ không bị lỗi bộ nhớ clipboard copy
Đúng rồi. Bạn dùng code của Batman1 đi. Tôi dùng thấy ổn.
 
Upvote 0
Mấy cái dữ liệu chứng khoán này lấy trực tiếp bằng API ấy, tải tập tin PDF về rồi nhặt ra kiểu gì cũng bị rơi chữ. Công mò lại cũng quá tội.
vâng bác, hiện mấy cái dữ liệu này các cty chứng khoán họ công bố ra theo dạng pdf cho nhà đầu tư kiểu đó tải về
API hình như không có cho cái dữ liệu pdf này..mà thú thực em cũng không hiểu API, trình em vẫn chỉ cố xào nấu trên excel bóc tách ra nếu có data copy vào thôi

Cứ có text copy vào excel là em tách được lên số e cần

1681285852698.png
 
Upvote 0
vâng bác, hiện mấy cái dữ liệu này các cty chứng khoán họ công bố ra theo dạng pdf cho nhà đầu tư kiểu đó tải về
API hình như không có cho cái dữ liệu pdf này..mà thú thực em cũng không hiểu API, trình em vẫn chỉ cố xào nấu trên excel bóc tách ra nếu có data copy vào thôi

Cứ có text copy vào excel là em tách được lên số e cần

View attachment 288868
Mấy cái file của bạn cấu trúc dữ liệu có giống nhau hoàn toàn không, ví dụ có cùng số dòng.
Nếu giống nhau thì bạn copy và nối vào excel như đang làm cũng được, còn nếu khác nhau thì mình hay cho tất cả dữ liệu của mỗi file vào từng ô, sau đó viết công thức gắp dữ liệu cần lấy ra, cũng giống kiểu bạn đang làm.
 
Lần chỉnh sửa cuối:
Upvote 0
Mấy cái file của bạn cấu trúc dữ liệu có giống nhau hoàn toàn không, ví dụ có cùng số dòng.
Nếu giống nhau thì bạn copy và nối vào excel như đang làm cũng được, còn nếu khác nhau thì mình hay cho tất cả dữ liệu của mỗi file vào từng ô, sau đó viết công thức gắp dữ liệu cần lấy ra, cũng giống kiểu bạn đang làm.
Đúng rồi bạn, mình có hàm tách bên phải rồi
Nếu có code import text files vào cột F thì sẽ đỡ thêm 1 bước copy tay từng file text vào file excel đích
 
Lần chỉnh sửa cuối:
Upvote 0
Đúng rồi bạn, mình có hàm tách bên phải rồi
Nếu có code import text files vào cột F thì sẽ đỡ thêm 1 bước copy tay từng file text vào file excel đích

Bạn thử chạy code bên dưới, chọn các file TXT cần lấy dữ liệu để đưa vào Excel, sau đó kiểm tra lại kết quả xem sao.

Mã:
Sub ABC()
    Dim X As FileDialog
    Dim Y As Variant
    Dim Row As Long
    Set X = Application.FileDialog(msoFileDialogFilePicker)
    X.Filters.Clear
    X.Filters.Add "Text files", "*.txt"
    X.AllowMultiSelect = True
    If X.Show = True Then
        For Each Y In X.SelectedItems
            Open Y For Input As #1
            Do Until EOF(1)
                Line Input #1, TextLine
                Row = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row + 1
                Cells(Row, 6).Value = TextLine
            Loop
            Close #1
        Next Y
    End If
End Sub
 
Upvote 0
Bạn thử chạy code bên dưới, chọn các file TXT cần lấy dữ liệu để đưa vào Excel, sau đó kiểm tra lại kết quả xem sao.
Cám ơn bạn rất nhiều, text data copy vào excel được rồi bạn, tuy bị mất dấu tiếng Việt nhưng phần data quan trọng cần dùng là ok rồi bạn ah

1681290046709.png
 
Upvote 0
Em thử mãi mà chỉ ra file trắng tinh, anh chạy thử giúp em file pdf này xem thế nào nhé. Xin cảm ơn anh.
Em chào anh Tuấn,
File PDF của anh em thấy đó là file scan anh ạ, cái này thì code chịu thôi anh.
Với những file này nếu là tiếng anh thì còn có thể dùng phần mềm đọc "OCR" (Nhận dạng ký tự quang học) để lấy dữ liệu nếu cần, còn với tiếng việt ta hiện nay thì chắc là đang bó chân toàn tập anh ạ.
 
Upvote 0
Em chào anh Tuấn,
File PDF của anh em thấy đó là file scan anh ạ, cái này thì code chịu thôi anh.
Với những file này nếu là tiếng anh thì còn có thể dùng phần mềm đọc "OCR" (Nhận dạng ký tự quang học) để lấy dữ liệu nếu cần, còn với tiếng việt ta hiện nay thì chắc là đang bó chân toàn tập anh ạ.
Thảo nào mình chạy mãi không được, chân thành cảm ơn bạn nhé.
 
Upvote 0
Em thử mãi mà chỉ ra file trắng tinh, anh chạy thử giúp em file pdf này xem thế nào nhé. Xin cảm ơn anh.
Nó tạo ra file text cùng đường dẫn với file nguồn mà bạn. Muốn chép lên sheet thì dùng thêm 1 hàm nữa.

P/S: À không đọc kỹ, chừ thấy mấy bạn trả lời rồi :)
 
Lần chỉnh sửa cuối:
Upvote 0
Nó tạo ra file text cùng đường dẫn với file nguồn mà bạn. Muốn chép lên sheet thì dùng thêm 1 hàm nữa.
Em thử rồi, nó cũng tạo ra file text, nhưng bên trong file vẫn trắng tinh, không thể hiện bất kỳ một ký tự nào cả nên em nhờ anh chạy thử xem có phải tại em chạy chưa đúng hay do vấn đề gì đó mà em chưa biết anh ạ.
 
Upvote 0
Em thử rồi, nó cũng tạo ra file text, nhưng bên trong file vẫn trắng tinh, không thể hiện bất kỳ một ký tự nào cả nên em nhờ anh chạy thử xem có phải tại em chạy chưa đúng hay do vấn đề gì đó mà em chưa biết anh ạ.
Tôi không đọc kỹ bài bạn. Có bạn trả lời thay rồi. File đó phải dùng ABBYY mới được.
 
Upvote 0
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 ạ.

View attachment 288488

Bạn debug.Print xem dòng màu vàng.

Nếu trường hợp đường dẫn là tiếng Việt thì cần thêm mã GetShortPath.
 
Upvote 0

Bài viết mới nhất

Back
Top Bottom