Nhờ Anh chị xem giúp em đoạn code tách trang đầu của file pdf dựa vào phần mềm PDFtk

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài
Có
H

Hoantk223

Thành viên mới
Tham gia
13/5/23
Bài viết
21
Được thích
1
Em có nhiều file cần tách lấy trang đầu tiên. Thay vì file đổi đường dẫn liên tục, thì e có đoạn code lấy đường dẫn của các file PDF cần đổi tên vào cột A. Và em muốn chạy code để tách các file theo lần lượt đường dẫn ở cột A. Hiện tại e đang bị lỗi ở phần bôi đỏ. Mọi người xem chỉnh giúp e với ạ. Em cảm ơn!
screenshot_1685592273.png

Sub SplitPDFtk()

Dim SourceFile As String, DestFile As String
Dim strParam As String, RetVal As String, PDFtk As String
Dim i As Integer

PDFtk = "C:\Program Files (x86)\PDFtk\bin\pdftk.exe "
Application.ScreenUpdating = False
For i = 1 To Cells(2, 1).Value
SourceFile = "Cells(2 + i, 1)"
Cells(2 + i, 3).Value = Done
Next

DestFile = "D:\" & "10" & Format(1, "00") & ".pdf"

strParam = SourceFile & " cat " & 1 & "-" & 1 & " output " & DestFile

RetVal = Shell(PDFtk & strParam, 0)


Application.ScreenUpdating = True

MsgBox "Done.", vbInformation

End Sub
Nhấp chuột vào đây để mở rộng...
 
Chưa hiểu mục đích bạn muốn làm cái gì?
>>For i = 1 To Cells(2, 1).Value
->Giá trị của Cells(2, 1).Value là bao nhiêu? nó phải là 1 con số nhé
 
Bạn muốn làm gì thì trình bày rõ ràng.
Trạng thái TRUE có ý nghĩa là gì ? Bạn ghi như vậy khó có thể hiểu được, thì sao mà có thể giúp.
Cụm màu đỏ của bạn sai rất nhiều thứ, cả về cách hiểu, cách truy xuất và kể cả gán kết quả.
 
huhumalu đã viết:
Bạn muốn làm gì thì trình bày rõ ràng.
Trạng thái TRUE có ý nghĩa là gì ? Bạn ghi như vậy khó có thể hiểu được, thì sao mà có thể giúp.
Cụm màu đỏ của bạn sai rất nhiều thứ, cả về cách hiểu, cách truy xuất và kể cả gán kết quả.
Nhấp chuột vào đây để mở rộng...
True là thể hiện các file đã được tách ạ. Mình muốn lấy file đầu tiên của file PDf dựa vào phần mềm PDFtk. Ban đầu mình có đoạn code sau. Nhưng thay vì phải đổi tên đường dẫn trong code liên tục thì giờ mình muốn lấy đường dẫn vào code A và tách theo đường dẫn ở cột A đã được gọi, Sau khi tách xong thì hiển thị trạng thái đã tách vào cột B
Sub SplitPDFtk()

Dim SourceFile As String, DestFile As String
Dim strParam As String, RetVal As String, PDFtk As String
Dim i As Long 'Integer

PDFtk = "C:\Program Files (x86)\PDFtk\bin\pdftk.exe "
'SourceFile = "D:\Thuy\2015\01\2015\001.pdf "
Next
Application.ScreenUpdating = False

'For i = 1 To 1

DestFile = "D:\" & "10" & Format(i, "00") & ".pdf"

strParam = SourceFile & " cat " & i & "-" & i & " output " & DestFile

RetVal = Shell(PDFtk & strParam, 0)

'Next i

Application.ScreenUpdating = True

MsgBox "Done.", vbInformation

End Sub
Nhấp chuột vào đây để mở rộng...
Bài đã được tự động gộp:

Nguyễn Duy Tứ đã viết:
Chưa hiểu mục đích bạn muốn làm cái gì?
>>For i = 1 To Cells(2, 1).Value
->Giá trị của Cells(2, 1).Value là bao nhiêu? nó phải là 1 con số nhé
Nhấp chuột vào đây để mở rộng...
Mình muốn chạy tách file theo đường dẫn ở cột A, dòng thứ 2 ạ
 
Bạn có thể tham khảo thử. Đúng sai tùy duyên.


Sub SplitPDFtk()
Dim SourceFile As String, DestFile As String
Dim strParam As String, RetVal As String, PDFtk As String
Dim i As Long

PDFtk = "C:\Program Files (x86)\PDFtk\bin\pdftk.exe "
Application.ScreenUpdating = False

For i = 1 To Cells(2, 1).Value
SourceFile = Cells(2 + i, 1).Value
Cells(2 + i, 3).Value = "Done"
For j = 1 To Cells(2 + i, 2).Value
DestFile = "D:\" & "Page " & Format(j, "00") & " of " & Cells(2 + i, 2).Value & " " & _
Left(Right(SourceFile, Len(SourceFile) - InStrRev(SourceFile, "\")), Len(SourceFile) - InStrRev(SourceFile, ".") + 1) & ".pdf"
strParam = PDFtk & SourceFile & " cat " & j & " output """ & DestFile & """"
RetVal = Shell(strParam, 0)
Next j
Next i

Application.ScreenUpdating = True
MsgBox "Done.", vbInformation
End Sub
 
@Hoantk223
Không cần dùng đến thư viện nào để giữ trang đầu tiên bạn nhé.

Chỉ cần chạy mã VBA là được rồi.

JavaScript: 
Option Explicit


Private Sub KeepingFirstPagePDF_test()
  Dim s, re As Object, FSO As Object, i&, rg, lr&
  Set rg = [A2]
  lr = rg(50000, 1).End(3).row - rg.row + 1
  s = "D:\PagePDF\"
  If CreateFolder(s, FSO) Then
    For i = 1 To lr
       If rg(i, 2).value <> empty then  rg(i, 2).value = KeepingFirstPagePDF(s, rg(i, 1).value, re, FSO)
    Next
    ActiveWorkbook.FollowHyperlink s, , True
  End If
End Sub
Private Function KeepingFirstPagePDF(ByVal vFolder$, ByVal vFileName$, Optional RegExp As Object, Optional FSO As Object)
  If Not vFileName Like "*.pdf" Then Exit Function
  If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
  If Not FSO.fileExists(vFileName) Then Exit Function
  Dim s$
  If RegExp Is Nothing Then
    Set RegExp = CreateObject("VBscript.RegExp")
    With RegExp
      .Global = True
      .IgnoreCase = True
      .MultiLine = True
      s = "[^" & ChrW(7893) & "]+"
      .Pattern = "(<</Type\s*/Page[^s]" & s & "?)\r?\n<</Type\s*/Page[^s]" & s & "\r?\n<</Type/XObject/" & s & "?\r?\nstream" & s & "?\r?\nendstream\r?\n(endobj)"
    End With
  End If
  Dim n, e, xFileNum As Long, ms, m, y%, f
  Dim b() As Byte
  If Right(vFolder, 1) <> "\" Then vFolder = vFolder & "\"
  s = ""
  e = Split(vFileName, "\"): e = e(UBound(e))
  n = Split(e, "."): e = n(UBound(n))
  n(UBound(n)) = "": n = Join(n, ".")
  xFileNum = FreeFile: Open vFileName For Binary As #xFileNum: s = Space(LOF(xFileNum)): Get #xFileNum, , s: Close #xFileNum
R:
  If RegExp.Test(s) Then
    s = RegExp.Replace(s, "$1$2"): y = y + 1: GoTo R
  End If
  If y Then
    With CreateObject("ADODB.Stream")
      .Mode = 3
      .Charset = "Windows-1252"
      .Open
      .Writetext s
      .Position = 0
      .SaveToFile vFolder & n & e, 2
      .Type = 2
      .Position = 3
    End With
    KeepingFirstPagePDF = y
  End If
End Function
Private Function CreateFolder(ByVal FolderPath As String, Optional ByRef FileSystem As Object) As Boolean
  Dim FolderArray, tmp$, i As Integer, UB As Integer, tFolder$
  tFolder = FolderPath
  If Right(tFolder, 1) = "\" Then tFolder = Left(tFolder, Len(tFolder) - 1)
  If tFolder Like "\\*\*" Then tFolder = Strings.Replace(tFolder, "\", "@", 1, 3)
  FolderArray = Split(tFolder, "\")
  If FileSystem Is Nothing Then
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
  End If
  On Error GoTo Ends
  FolderArray(0) = Strings.Replace(FolderArray(0), "@", "\", 1, 3)
  UB = UBound(FolderArray)
  With FileSystem
    For i = 0 To UB
      tmp = tmp & FolderArray(i) & "\"
      If Not .FolderExists(tmp) Then .CreateFolder (tmp)
      CreateFolder = (i = UB) And Len(FolderArray(i)) > 0 And FolderArray(i) <> " "
    Next
  End With
Ends:
End Function
 
befaint đã viết:
Em bỏ dòng đó đi để xem mức độ chịu khó thôi mà. ;)
Nhấp chuột vào đây để mở rộng...
dạ VBA mình mới đang bắt đầu tự tìm hiểu nên có rất nhiều cái mình vẫn chưa biết ạ
Bài đã được tự động gộp:

HeSanbi đã viết:
@Hoantk223
Không cần dùng đến thư viện nào để giữ trang đầu tiên bạn nhé.

Chỉ cần chạy mã VBA là được rồi.

JavaScript: 
Option Explicit


Private Sub KeepingFirstPagePDF_test()
  Dim s, re As Object, FSO As Object, i&, rg, lr&
  Set rg = [A2]
  lr = rg(50000, 1).End(3).row - rg.row + 1
  s = "D:\PagePDF\"
  If CreateFolder(s, FSO) Then
    For i = 1 To lr
       If rg(i, 2).value <> empty then  rg(i, 2).value = KeepingFirstPagePDF(s, rg(i, 1).value, re, FSO)
    Next
    ActiveWorkbook.FollowHyperlink s, , True
  End If
End Sub
Private Function KeepingFirstPagePDF(ByVal vFolder$, ByVal vFileName$, Optional RegExp As Object, Optional FSO As Object)
  If Not vFileName Like "*.pdf" Then Exit Function
  If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
  If Not FSO.fileExists(vFileName) Then Exit Function
  Dim s$
  If RegExp Is Nothing Then
    Set RegExp = CreateObject("VBscript.RegExp")
    With RegExp
      .Global = True
      .IgnoreCase = True
      .MultiLine = True
      s = "[^" & ChrW(7893) & "]+"
      .Pattern = "(<</Type\s*/Page[^s]" & s & "?)\r?\n<</Type\s*/Page[^s]" & s & "\r?\n<</Type/XObject/" & s & "?\r?\nstream" & s & "?\r?\nendstream\r?\n(endobj)"
    End With
  End If
  Dim n, e, xFileNum As Long, ms, m, y%, f
  Dim b() As Byte
  If Right(vFolder, 1) <> "\" Then vFolder = vFolder & "\"
  s = ""
  e = Split(vFileName, "\"): e = e(UBound(e))
  n = Split(e, "."): e = n(UBound(n))
  n(UBound(n)) = "": n = Join(n, ".")
  xFileNum = FreeFile: Open vFileName For Binary As #xFileNum: s = Space(LOF(xFileNum)): Get #xFileNum, , s: Close #xFileNum
R:
  If RegExp.Test(s) Then
    s = RegExp.Replace(s, "$1$2"): y = y + 1: GoTo R
  End If
  If y Then
    With CreateObject("ADODB.Stream")
      .Mode = 3
      .Charset = "Windows-1252"
      .Open
      .Writetext s
      .Position = 0
      .SaveToFile vFolder & n & e, 2
      .Type = 2
      .Position = 3
    End With
    KeepingFirstPagePDF = y
  End If
End Function
Private Function CreateFolder(ByVal FolderPath As String, Optional ByRef FileSystem As Object) As Boolean
  Dim FolderArray, tmp$, i As Integer, UB As Integer, tFolder$
  tFolder = FolderPath
  If Right(tFolder, 1) = "\" Then tFolder = Left(tFolder, Len(tFolder) - 1)
  If tFolder Like "\\*\*" Then tFolder = Strings.Replace(tFolder, "\", "@", 1, 3)
  FolderArray = Split(tFolder, "\")
  If FileSystem Is Nothing Then
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
  End If
  On Error GoTo Ends
  FolderArray(0) = Strings.Replace(FolderArray(0), "@", "\", 1, 3)
  UB = UBound(FolderArray)
  With FileSystem
    For i = 0 To UB
      tmp = tmp & FolderArray(i) & "\"
      If Not .FolderExists(tmp) Then .CreateFolder (tmp)
      CreateFolder = (i = UB) And Len(FolderArray(i)) > 0 And FolderArray(i) <> " "
    Next
  End With
Ends:
End Function
Nhấp chuột vào đây để mở rộng...
Dạ em cho chạy thử mà nó lại báo vướng ở chỗ này, a xem giúp e với ạ
1686793115496.png
 
phankhanhbm đã viết:
Bạn có thể tham khảo thử. Đúng sai tùy duyên.


Sub SplitPDFtk()
Dim SourceFile As String, DestFile As String
Dim strParam As String, RetVal As String, PDFtk As String
Dim i As Long

PDFtk = "C:\Program Files (x86)\PDFtk\bin\pdftk.exe "
Application.ScreenUpdating = False

For i = 1 To Cells(2, 1).Value
SourceFile = Cells(2 + i, 1).Value
Cells(2 + i, 3).Value = "Done"
For j = 1 To Cells(2 + i, 2).Value
DestFile = "D:\" & "Page " & Format(j, "00") & " of " & Cells(2 + i, 2).Value & " " & _
Left(Right(SourceFile, Len(SourceFile) - InStrRev(SourceFile, "\")), Len(SourceFile) - InStrRev(SourceFile, ".") + 1) & ".pdf"
strParam = PDFtk & SourceFile & " cat " & j & " output """ & DestFile & """"
RetVal = Shell(strParam, 0)
Next j
Next i

Application.ScreenUpdating = True
MsgBox "Done.", vbInformation
End Sub
Nhấp chuột vào đây để mở rộng...
Ở đoạn này mình chạy từng dòng thấy đang bị báo ở chỗ này. Bạn xem giúp mình với ạ :(
1686793796876.png
 

File đính kèm

  • Test1.rar
    1.2 MB · Đọc: 35
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

S
  • Question
Không lấy đủ dữ liệu bằng kết nối ADO
Trả lời
12
Đọc
234
Quang_Hải
Quang_Hải
Nimda
[Hỏi] Về việc in biên bản nghiệm thu hàng loạt tự động
2
Trả lời
37
Đọc
7K
kiencuong030184
kiencuong030184
A
V/v gửi mail hàng loạt bằng mail
Trả lời
0
Đọc
1
acca_hcm
A
T
V/v code xử lý dữ liệu bị chậm
Trả lời
8
Đọc
91
tuanxitin
T
th7
Hỗ trợ công thức để lấy kết quả dựa theo nút danh sách thả xuống (Drop List) và bảng dữ liệu.
Trả lời
0
Đọc
15
th7
th7
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom