Nhờ Anh Chị viết code xuất PDF từ excel giúp. xin cảm ơn.

gaubongcuaanh · 13/4/20

Em có một công việc nhờ anh chị giúp đỡ. có một danh sách khách hàng và một mẫu in trong cùng một excel. em muốn kết xuất ra PDF mỗi khách hàng một file. Tên lưu theo mã khách hàng. rất mong anh chị giúp đỡ. em xin trân thành cảm ơn nhiều.

Bluestar092011 · 14/4/20

gaubongcuaanh đã viết:
Em có một công việc nhờ anh chị giúp đỡ. có một danh sách khách hàng và một mẫu in trong cùng một excel. em muốn kết xuất ra PDF mỗi khách hàng một file. Tên lưu theo mã khách hàng. rất mong anh chị giúp đỡ. em xin trân thành cảm ơn nhiều.

Dùng thử code này.

Mã:

Sub Xuat_PDF()
'On Error Resume Next
  Dim i%, j%
  Dim PdfFile As String, Arr
    PdfFile = ThisWorkbook.Path
    If Right(PdfFile, 1) <> "\" Then PdfFile = PdfFile & "\"
    Arr = Sheet1.Range("B2:H" & Sheet1.Range("B65000").End(xlUp).Row).Value
    With Sheet2
        .PageSetup.PrintArea = .Range("A1:B11").Address
        For i = 1 To UBound(Arr)
            s = PdfFile & Arr(i, 1) & ".pdf"
            For j = 1 To 7
                .Range("B" & (j + 4)).Value = Arr(i, j)
            Next j
            .ExportAsFixedFormat Type:=xlTypePDF, Filename:=s, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        Next i
    End With
    MsgBox "Da xuat xong"
End Sub

Dùng code này chưa bẩy lỗi, do tôi nghĩ cột Mã khách hàng chắc không trùng. Các tệp PDF xuất cùng thư mục với file excel.

babyheomoi · 14/4/20

Bluestar092011 đã viết:
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=s, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

Cho em hỏi nếu muốn thêm pass vào thì thêm dòng này như thế nào?

giaiphap · 14/4/20

babyheomoi đã viết:
Cho em hỏi nếu muốn thêm pass vào thì thêm dòng này như thế nào?

Dùng code ở #2 kết hợp chút với code này.

Making Password Protected PDFs using Excel Vba and PDFtk Tool [SOLVED]

I am using excel to process salary. I have one sheet for Salary Data and other Sheet for Salary Slip. I am using Vlookup function for making salary slips. Right Now, I change one value (on which vlookup is based) and it gives the numbers related to that salary slip. Then, I save that salary...

www.excelforum.com

Mã:

Option Explicit

Sub Xuat_PDF()
'On Error Resume Next
  Dim i%, j%, FileName$
  Dim PdfFile As String, Arr
    PdfFile = ThisWorkbook.Path
    If Right(PdfFile, 1) <> "\" Then PdfFile = PdfFile & "\"
    Arr = Sheet1.Range("B2:H" & Sheet1.Range("B65000").End(xlUp).Row).Value
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Sheet2
        .PageSetup.PrintArea = .Range("A1:B11").Address
        For i = 1 To UBound(Arr)
            FileName = PdfFile & Arr(i, 1) & ".pdf"
            For j = 1 To 7
                .Range("B" & (j + 4)).Value = Arr(i, j)
            Next j
            '.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FileName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            Call PdfPwd(Sheet2, FileName, "GPE")
        Next i
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Da xuat sang PDF xong"
End Sub

'Truoc het phai tai phan mem nay ve may
'Download PDFtk Free : https://www.pdflabs.com/tools/pdftk-the-pdf-toolkit/

Sub PdfPwd(sh As Worksheet, oPdf As String, Pwd As String)
   
    Dim fTemp As String, cmdStr As String                               'Defining Variables
    fTemp = Environ("Temp") & "\" & "Temp.Pdf"
   
    sh.ExportAsFixedFormat Type:=xlTypePDF, FileName:=fTemp, Quality:=xlQualityStandard
   
    fTemp = """" & fTemp & """"                           'Putting extra "" around for command Parameter.
    oPdf = """" & oPdf & """"
    Pwd = """" & Pwd & """"
                                                          'Making Command String for making protected PDFs Using PDFtk tool.
    cmdStr = "pdftk " & fTemp _
                      & " Output " & oPdf _
                      & " User_pw " & Pwd _
                      & " Allow AllFeatures"
    Shell cmdStr, vbHide                                  'Executing PDFtk Command.
    Application.Wait DateAdd("s", 2, Now)                 'Allowing 2 secs for command to execute.
    Kill Replace(fTemp, """", "")                         'Deleting temporary files.
End Sub

Lưu ý: Tải và cài đặt PDFtk Free trước khi dùng code.

https://www.pdflabs.com/tools/pdftk-the-pdf-toolkit/

neyugngnort · 14/4/20

Dim i%, j%
Khai báo biến như vầy nghĩa là sao vậy anh

giaiphap · 14/4/20

neyugngnort đã viết:
Dim i%, j%
Khai báo biến như vầy nghĩa là sao vậy anh

Tương đương: Dim i As Integer, j As Integer

gaubongcuaanh · 14/4/20

Em xin cảm ơn tất cả các anh các chị. xin trân thành cảm ơn rất nhiều. Chúc các anh chị và GĐ mạnh khỏe!

babyheomoi · 15/4/20

Em có xài 1 excel của 1 mem trên đây, code thế này, nhưng e chỉnh sửa để set pass thì chưa được, mấy anh xem giúp em là giờ mình sửa code này thế nào? Hay add code a giaiphap vào thế nào để set được pass. Phần đặt tên file pdf nữa!

Mã:

Function Create_PDF(Myvar As Object, FixedFilePathName As String, _
                        OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
    Dim FileFormatstr As String
    Dim Fname As Variant

    'Test If the Microsoft Add-in is installed
    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
         & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

        If FixedFilePathName = "" Then
            'Open the GetSaveAsFilename dialog to enter a file name for the pdf
            FileFormatstr = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, Title:="Create PDF")

            'If you cancel this dialog Exit the function
            If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If

        'If OverwriteIfFileExist = False we test if the PDF
        'already exist in the folder and Exit the function if that is True
        If OverwriteIfFileExist = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If

        'Now the file name is correct we Publish to PDF
        On Error Resume Next
        Myvar.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                FileName:=Fname, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=OpenPDFAfterPublish
        On Error GoTo 0

        'If Publish is Ok the function will return the file name
        If Dir(Fname) <> "" Then Create_PDF = Fname
    End If
End Function

giaiphap · 15/4/20

babyheomoi đã viết:

Em có xài 1 excel của 1 mem trên đây, code thế này, nhưng e chỉnh sửa để set pass thì chưa được, mấy anh xem giúp em là giờ mình sửa code này thế nào? Hay add code a giaiphap vào thế nào để set được pass. Phần đặt tên file pdf nữa!

Mã:

Function Create_PDF(Myvar As Object, FixedFilePathName As String, _
                        OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
    Dim FileFormatstr As String
    Dim Fname As Variant

    'Test If the Microsoft Add-in is installed
    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
         & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

        If FixedFilePathName = "" Then
            'Open the GetSaveAsFilename dialog to enter a file name for the pdf
            FileFormatstr = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, Title:="Create PDF")

            'If you cancel this dialog Exit the function
            If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If

        'If OverwriteIfFileExist = False we test if the PDF
        'already exist in the folder and Exit the function if that is True
        If OverwriteIfFileExist = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If

        'Now the file name is correct we Publish to PDF
        On Error Resume Next
        Myvar.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                FileName:=Fname, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=OpenPDFAfterPublish
        On Error GoTo 0

        'If Publish is Ok the function will return the file name
        If Dir(Fname) <> "" Then Create_PDF = Fname
    End If
End Function

Sửa code lại một chút nhé.

Mã:

Function Create_PDF(Myvar As Object, FixedFilePathName As String, _
                        OverwriteIfFileExist As Boolean, Pwd As String) As String
    Dim FileFormatstr As String
    Dim Fname As Variant
    Dim fTemp As String, cmdStr As String
    fTemp = Environ("Temp") & "\" & "Temp.Pdf"
    'Test If the Microsoft Add-in is installed
    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
         & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

        If FixedFilePathName = "" Then
            'Open the GetSaveAsFilename dialog to enter a file name for the pdf
            FileFormatstr = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, Title:="Create PDF")

            'If you cancel this dialog Exit the function
            If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If

        'If OverwriteIfFileExist = False we test if the PDF
        'already exist in the folder and Exit the function if that is True
        If OverwriteIfFileExist = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If

        'Now the file name is correct we Publish to PDF
        'On Error Resume Next
        Myvar.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                Filename:=fTemp, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=False
        
        fTemp = """" & fTemp & """"                           'Putting extra "" around for command Parameter.
        oPdf = """" & Fname & """"
        Pwd = """" & Pwd & """"
                                                              'Making Command String for making protected PDFs Using PDFtk tool.
        cmdStr = "pdftk " & fTemp _
                          & " Output " & oPdf _
                          & " User_pw " & Pwd _
                          & " Allow AllFeatures"
        Shell cmdStr, vbHide                                  'Executing PDFtk Command.
        Application.Wait DateAdd("s", 2, Now)                 'Allowing 2 secs for command to execute.
        Kill Replace(fTemp, """", "")
        'On Error GoTo 0

        'If Publish is Ok the function will return the file name
        If Dir(Fname) <> "" Then Create_PDF = Fname
    End If
End Function

Hàm sửa lại bỏ tham số OpenPDFAfterPublish (Tham số này True nếu muốn tạo xong sẽ mở file luôn), do nguyên tắc của hàm là tạo ra file PDF ở thư mục tạm, xong copy file PDF vừa tạo xong đó đến đường dẫn người dùng chọn và tạo Password cho file PDF này, tiếp theo sẽ xóa file PDF tạm (File đã tạo ra ở thư mục tạm) này, nhưng lỡ người dụng đặt tham số OpenPDFAfterPublish=true thì sẽ xảy ra lỗi (Do xóa file đang mở). Chính vì điều này mà tôi bỏ đi tham số này.
Ta dùng code sau để tạo file PDF có tên abc.pdf nằm cùng thư mục với file đang sử dụng và có mật khẩu mở file là 123:

Mã:

MsgBox Create_PDF(Sheet2, ThisWorkbook.Path & "\abc.pdf", True, "123")

babyheomoi · 16/4/20

Bác ơi, em thử nhưng bị lỗi, không biết e set sai dòng nào

Em đưa file lên luôn có gì mấy anh xem sửa giúp em nha!

giaiphap · 16/4/20

babyheomoi đã viết:
Bác ơi, em thử nhưng bị lỗi, không biết e set sai dòng nào
View attachment 235768

Em đưa file lên luôn có gì mấy anh xem sửa giúp em nha!

Sơ xuất chưa khai báo biến oPdf, chỉ cần thêm khai báo biến đó nửa là xong.

Mã:

Function Create_PDF(Myvar As Object, FixedFilePathName As String, _
                        OverwriteIfFileExist As Boolean, Pwd As String) As String
    Dim FileFormatstr As String, oPdf As String
    Dim Fname As Variant
    Dim fTemp As String, cmdStr As String
    fTemp = Environ("Temp") & "\" & "Temp.Pdf"
    'Test If the Microsoft Add-in is installed
    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
         & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

        If FixedFilePathName = "" Then
            'Open the GetSaveAsFilename dialog to enter a file name for the pdf
            FileFormatstr = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, Title:="Create PDF")

            'If you cancel this dialog Exit the function
            If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If

        'If OverwriteIfFileExist = False we test if the PDF
        'already exist in the folder and Exit the function if that is True
        If OverwriteIfFileExist = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If

        'Now the file name is correct we Publish to PDF
        'On Error Resume Next
        Myvar.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                FileName:=fTemp, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=False
        
        fTemp = """" & fTemp & """"                           'Putting extra "" around for command Parameter.
        oPdf = """" & Fname & """"
        Pwd = """" & Pwd & """"
                                                              'Making Command String for making protected PDFs Using PDFtk tool.
        cmdStr = "pdftk " & fTemp _
                          & " Output " & oPdf _
                          & " User_pw " & Pwd _
                          & " Allow AllFeatures"
        Shell cmdStr, vbHide                                  'Executing PDFtk Command.
        Application.Wait DateAdd("s", 2, Now)                 'Allowing 2 secs for command to execute.
        Kill Replace(fTemp, """", "")
        'On Error GoTo 0

        'If Publish is Ok the function will return the file name
        If Dir(Fname) <> "" Then Create_PDF = Fname
    End If
End Function

Kiều Mạnh · 16/4/20

giaiphap đã viết:

Sơ xuất chưa khai báo biến oPdf, chỉ cần thêm khai báo biến đó nửa là xong.

Mã:

Function Create_PDF(Myvar As Object, FixedFilePathName As String, _
                        OverwriteIfFileExist As Boolean, Pwd As String) As String
    Dim FileFormatstr As String, oPdf As String
    Dim Fname As Variant
    Dim fTemp As String, cmdStr As String
    fTemp = Environ("Temp") & "\" & "Temp.Pdf"
    'Test If the Microsoft Add-in is installed
    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
         & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

        If FixedFilePathName = "" Then
            'Open the GetSaveAsFilename dialog to enter a file name for the pdf
            FileFormatstr = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, Title:="Create PDF")

            'If you cancel this dialog Exit the function
            If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If

        'If OverwriteIfFileExist = False we test if the PDF
        'already exist in the folder and Exit the function if that is True
        If OverwriteIfFileExist = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If

        'Now the file name is correct we Publish to PDF
        'On Error Resume Next
        Myvar.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                FileName:=fTemp, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=False
       
        fTemp = """" & fTemp & """"                           'Putting extra "" around for command Parameter.
        oPdf = """" & Fname & """"
        Pwd = """" & Pwd & """"
                                                              'Making Command String for making protected PDFs Using PDFtk tool.
        cmdStr = "pdftk " & fTemp _
                          & " Output " & oPdf _
                          & " User_pw " & Pwd _
                          & " Allow AllFeatures"
        Shell cmdStr, vbHide                                  'Executing PDFtk Command.
        Application.Wait DateAdd("s", 2, Now)                 'Allowing 2 secs for command to execute.
        Kill Replace(fTemp, """", "")
        'On Error GoTo 0

        'If Publish is Ok the function will return the file name
        If Dir(Fname) <> "" Then Create_PDF = Fname
    End If
End Function

Sao Mình thử chạy nó lỗi dòng nay ??

Mã:

Shell cmdStr, vbHide

babyheomoi · 16/4/20

Ah được rồi, cám ơn bác! Sẵn cho em hỏi thêm, em muốn Pass của mỗi người sẽ nằm ở cột D sheet Mailinfo. Em sửa code thêm cho nào ạ>

giaiphap · 16/4/20

kieu manh đã viết:
Sao Mình thử chạy nó lỗi dòng nay ??

Mã:

Shell cmdStr, vbHide

Đọc kỷ #4.

babyheomoi đã viết:
Ah được rồi, cám ơn bác! Sẵn cho em hỏi thêm, em muốn Pass của mỗi người sẽ nằm ở cột D sheet Mailinfo. Em sửa code thêm cho nào ạ>

Thiết kế file hoàn chỉnh đi rồi tính, hiện tại file của bạn cột D trống trơn.

Kiều Mạnh · 17/4/20

Eo ôi phải cài xong mới cho xài ... Mạnh dị ứng nhất là cái đó trừ khi cùng đường hay máy chuẩn bị ghost lại Windows thì cài quậy chơi thử
Thôi 123 Run đó ... các Bạn ở lại chơi Vui vẻ he

babyheomoi · 17/4/20

Em gửi lại file, em muốn sửa tên file thành cột D, và pass như cột E, mấy anh chị giúp em nhé!

giaiphap · 17/4/20

babyheomoi đã viết:
Em gửi lại file, em muốn sửa tên file thành cột D, và pass như cột E, mấy anh chị giúp em nhé!

File bạn quá nhiều code kiểm tra qua lại mệt (không kiên nhẫn) mà bạn lại tại sub Make_RangeOfSheet_To_PDF để in trong khi không truyền tham số Password rồi làm sao để export pdf kèm password được.
Tôi tạm sửa thế này (Do máy tôi không cài outlook nên không test code được).
Thứ nhất sub Make_RangeOfSheet_To_PDF thêm một tham số nửa, cụ thể sửa lại như sau:

Mã:

Sub Make_RangeOfSheet_To_PDF(File_Name As String, Range_of_Sheet As Object, aPass As String)

Và thay chổ "123" thành aPass.
Bên Sub Send_Email khai báo thêm 2 tham số nửa như sau:

Mã:

    Dim objOutlook As Object
    Dim pdfName As String, pdfPas As String

Cũng trong sub này phía dưới lệnh

Mã:

strMailAddress = Application.WorksheetFunction.VLookup(shSendMail.Cells(Rnum, 1).Value, _
                                                                       shMailInfo.Range("A1:C" & shMailInfo.Rows.Count), _
                                                                       3, _
                                                                       False)

thêm 2 dòng lệnh này vào.

Mã:

pdfName = Application.WorksheetFunction.VLookup(shSendMail.Cells(Rnum, 1).Value, _
                                                                       shMailInfo.Range("A1:D" & shMailInfo.Rows.Count), _
                                                                       4, _
                                                                       False)
                pdfPas = Application.WorksheetFunction.VLookup(shSendMail.Cells(Rnum, 1).Value, _
                                                                       shMailInfo.Range("A1:E" & shMailInfo.Rows.Count), _
                                                                       5, _
                                                                       False)

Thay dòng lệnh

Mã:

Call Make_RangeOfSheet_To_PDF(.....)

thành

Mã:

Call Make_RangeOfSheet_To_PDF(ThisWorkbook.Path & "\" & pdfName & ".pdf", shSendMail, pdfPas)

Nói trước với bạn là sẽ báo lỗi do trong sheet Send_Mail của bạn cột A, Mã NV có các số 5, 6, 7, 8 mà trong sheet Mailinfo của bạn không có mã này. Nói chung dữ liệu giả lập của bạn không giống thực tế tôi chỉ giúp lần này, bạn tự nghiên cứu tiếp.

babyheomoi · 17/4/20

Mã:

If Dir(Fname) <> "" Then Create_PDF = Fname

Chạy code tới dòng cuối mới bị lỗi bác ơi!

Bài đã được tự động gộp: 17/4/20

Mã:

If Dir(Fname) <> "" Then Create_PDF = Fname

Chạy code tới dòng cuối mới bị lỗi bác ơi

giaiphap đã viết:
Nói trước với bạn là sẽ báo lỗi do trong sheet Send_Mail của bạn cột A, Mã NV có các số 5, 6, 7, 8 mà trong sheet Mailinfo của bạn không có mã này.

Em sửa lại rồi anh ơi!

mingchou · 30/3/22

Em muốn file PDF xuất ra có password. AC hướng dẫn em thêm code vào với ạ. Em cảm ơn !

befaint · 5/5/22

mingchou đã viết:
Em muốn file PDF xuất ra có password. AC hướng dẫn em thêm code vào với ạ. Em cảm ơn !

Đây nhé bạn .

[ Python và ứng dụng ] Thư viện VBA gộp và tạo mật khẩu files PDF hàng loạt siêu bảo mật

[ Python và ứng dụng ] Thư viện VBA gộp và tạo mật khẩu files PDF hàng loạt siêu bảo mật. Tiếp một ứng dụng của Python làm thư viện cho VBA: Gộp và tạo mật khẩu files PDF hàng loạt siêu bảo mật. Thư viện vô cùng hữu ích cho công việc lập hồ sơ xuất PDF hàng loạt rồi cần gộp các files PDF lại...

www.giaiphapexcel.com

Nhờ Anh Chị viết code xuất PDF từ excel giúp. xin cảm ơn.

Sexy Girls from your town for night

File đính kèm

Thành viên hoạt động

Thành viên thường trực

==(^o^)==

Thành viên chính thức

==(^o^)==

Sexy Girls from your town for night

Thành viên thường trực

==(^o^)==

Thành viên thường trực

File đính kèm

==(^o^)==

I don't program, I beat code into submission!!!

Thành viên thường trực

==(^o^)==

I don't program, I beat code into submission!!!

Thành viên thường trực

File đính kèm

==(^o^)==

Thành viên thường trực

Thành viên mới

File đính kèm

|||||||||||||