时间戳

首页 > 解决方案 > Excel VBA - 打印现有的 PDF 文件，然后在打印时删除

excel - Excel VBA - 打印现有的 PDF 文件，然后在打印时删除

问题描述

我正在使用 Excel 来编译现有的 PDF 文件并通过电子邮件发送或打印它们，具体取决于收件人首选的联系方式。

代码（如下）运行后，我希望删除文件。我曾尝试使用 Kill 功能，但发现我收到错误“运行时错误 '70' - 权限被拒绝”。

我假设这是因为当 kill 函数尝试删除时，Acrobat Reader 仍在使用至少一个文件。我已经将 kill 函数单独用于主代码，它似乎工作正常。

有没有办法暂停代码直到打印完成？

提前谢谢了......

    Option Explicit

    Declare Function apiShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
        ByVal hwnd As Long, _
        ByVal lpOperation As String, _
        ByVal lpFile As String, _
        ByVal lpParameters As String, _
        ByVal lpDirectory As String, _
        ByVal nShowCmd As Long) _
        As Long

    Public Sub PrintFile(ByVal strPathAndFilename As String)

    Call apiShellExecute(Application.hwnd, "print", strPathAndFilename, vbNullString, vbNullString, 0)

    End Sub

    Sub SEND_BUDGETS()

    Dim FILE_NAME As String
    Dim OUT_APP As Outlook.Application
    Dim OUT_MAIL As Outlook.MailItem
    Dim A As Integer
    Dim B As Integer
    Dim C As String
    Dim YEAR_END As Integer
    Dim PROP_FOLDER As String

    If Sheet2.Range("A1").Value <> "ref" Then

        MsgBox ("Invalid data entered - Please try again")

        Exit Sub

    End If


    Application.ScreenUpdating = False

    Sheet1.Visible = True

    YEAR_END = InputBox("Please enter service charge period end year")

    PROP_FOLDER = Sheet2.Range("A2") & " - " & Sheet2.Range("B2")

    If Dir("G:\accounts\Service Charge Team\Sent Budget Packs\P" & PROP_FOLDER, vbDirectory) = vbNullString Then

        MkDir "G:\accounts\Service Charge Team\Sent Budget Packs\P" & PROP_FOLDER

        MkDir "G:\accounts\Service Charge Team\Sent Budget Packs\P" & PROP_FOLDER & "\" & YEAR_END

    Else

        If Dir("G:\accounts\Service Charge Team\Sent Budget Packs\P" & PROP_FOLDER & "\" & YEAR_END, vbDirectory) <> vbNullString Then

            MsgBox ("Folder for year end " & YEAR_END & " already exists - Please try again")

            Sheet1.Visible = xlVeryHidden

            Application.ScreenUpdating = True

            Exit Sub

        Else

            MkDir "G:\accounts\Service Charge Team\Sent Budget Packs\P" & PROP_FOLDER & "\" & YEAR_END

        End If

    End If


    'GET LIST OF FILES FROM "FILES TO SEND" FOLDER

    Sheet1.Range("A2:A2000").ClearContents

    FILE_NAME = Dir("G:\accounts\Service Charge Budget Emailer\Files To Send\" & "*.*")

    Sheet1.Activate

    Sheet1.Range("A2").Activate

    Application.Calculation = xlManual

    Do While Len(FILE_NAME) > 0

        ActiveCell.Value = FILE_NAME

        FILE_NAME = Dir

        ActiveCell.Offset(1, 0).Select

    Loop

    Application.Calculation = xlAutomatic

    ThisWorkbook.RefreshAll


    'CHECK IF FILES HAVE BEEN FOUND

    If Sheet1.Range("A1").Value = "FILE LIST - 0" Then

        Sheet1.Visible = xlVeryHidden

        Application.ScreenUpdating = True

        Sheet2.Select

        MsgBox ("Please add files to:-" & vbNewLine & vbNewLine & "G:\accounts\Service Charge Budget Emailer\Files To Send\")

        Exit Sub

    End If


    'SEND EMAILS

    Set OUT_APP = GetObject(, "Outlook.Application")

     If Err.Number = 429 Then

        Set OUT_APP = CreateObject("Outlook.Application")

     End If


    On Error Resume Next

    For A = 2 To Range("D2001").End(xlUp).Row

        Set OUT_MAIL = OUT_APP.CreateItem(olMailItem)

        If Sheet1.Range("N" & A).Value = "EMAIL" Then

            With OUT_MAIL

            .HTMLBody = "<BODY style=font-size:11pt;font-family:Calibri>Dear Proprietor,<p>" _
                            & "Please find attached service charge budget and any related paperwork in reference to the subject property.<p>" _
                            & "Kind regards,<p>"
             .To = Cells(A, 15).Value
             .Subject = Cells(A, 16).Value & " - Year Ending " & YEAR_END
             .Attachments.Add Cells(A, 9).Value
             .Attachments.Add Cells(A, 10).Value
             .Attachments.Add Cells(A, 11).Value
             .Attachments.Add Cells(A, 12).Value
             .Attachments.Add Cells(A, 13).Value
             .SaveAs "G:\accounts\Service Charge Team\Sent Budget Packs\P" & PROP_FOLDER & "\" & YEAR_END & "\" & Cells(A, 16) & " - Year Ending " & YEAR_END & ".msg", OlSaveAsType.olMSG
             .Send

            End With

        ElseIf Sheet1.Range("N" & A).Value = "PRINT" Then

            On Error GoTo 0

            For B = 9 To 13

                If Cells(A, B) <> "" Then

                    C = Cells(A, B).Value

                    PrintFile (C)

                    If Dir("G:\accounts\Service Charge Team\Sent Budget Packs\P" & PROP_FOLDER & "\" & YEAR_END & "\" & Cells(A, 16), vbDirectory) = vbNullString Then

                        MkDir "G:\accounts\Service Charge Team\Sent Budget Packs\P" & PROP_FOLDER & "\" & YEAR_END & "\" & Cells(A, 16)

                    End If

                    FileCopy C, "G:\accounts\Service Charge Team\Sent Budget Packs\P" & PROP_FOLDER & "\" & YEAR_END & "\" & Cells(A, 16) & "\" & Cells(A, B - 5)

                End If

            Next B

        End If

    Next A

    Kill ("G:\accounts\Service Charge Budget Emailer\Files To Send\" & "*.*")

    Sheet1.Visible = xlVeryHidden

    Application.ScreenUpdating = True

    MsgBox ("Complete")

标签： excelvba

解决方案

推荐阅读