时间戳

首页 > 解决方案 > Excel VBA，使用Shell“打印”保护pdf到另一个pdf文件

vba - Excel VBA，使用Shell“打印”保护pdf到另一个pdf文件

问题描述

我在 Outlook 的一个文件夹中进行了搜索，找到了所有具有已定义标题的电子邮件，并通过 Excel VBA 将其附件下载到了一个文件夹中。

我现在需要通过 VBA 通过 Adob​​e Reader XI 将它们打印到新的 pdf 文件中——因为它们受密码保护——以便能够转换为 RFT（我使用 VBA 从转换为 RFT 的 PDF 中获取数据）。

仅当已保存的 pdf 文件打印到辅助 pdf 时，才会以某种方式创建正确的 RF 布局——保存不起作用——无论是通过资源管理器 pdf 查看器、Nitro 还是 Adob​​e 都没有区别。

我已经尝试过 Attachment.Printout 但得到对象不支持的错误，我无法在 aShellexecute中找到允许打印到文件的选项，因为在线主要建议允许通过以下方式打印：

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

带有选项/p和/h打印。关于如何使用或不使用 shell（或直接将受保护的 pdf 转换为 rft）的任何帮助。我使用的自动下载文件的代码（从 VBA 借用和编辑，以循环浏览电子邮件附件并根据给定条件保存）如下所示：

Sub email234()

Application.ScreenUpdating = False

    Dim sPSFileName As String
    Dim sPDFFileName As String
    Dim olApp As Object
    Dim ns As Namespace

    Set olApp = CreateObject("Outlook.Application")
    Set ns = olApp.GetNamespace("MAPI")
    Dim oItem As Object
    Dim olMailItem As Outlook.MailItem


   Dim olNameSpace As Object
   Dim olFolder As Object
   Dim olFolderName As String
   Dim olAtt As Outlook.Attachments
   Dim strName As String
   Dim sPath As String
   Dim i As Long
   Dim j As Integer
   Dim olSubject As String
   Dim olSender As String
   Dim sh As Worksheet
   Dim LastRow As Integer

olFolderName = "\\Subscriptions\Inbox" 'ThisWorkbook.Worksheets("Control").Range("D10")
olSender = "Argus Alerts" 'ThisWorkbook.Worksheets("Control").Range("D16")

sPath = Application.FileDialog(msoFileDialogFolderPicker).Show
sPathstr = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)

Set olNameSpace = olApp.GetNamespace("MAPI")

'check if folder is subfolder or not and choose olFolder accordingly
    Set olFolder = ns.Folders("Subscriptions").Folders("Inbox")
   strName = "Argus Ammonia"

h = 2
For i = 1 To olFolder.Items.Count

    If olFolder.Items(i).Class <> olMail Then
    Else
        Set olMailItem = olFolder.Items(i)

        'check if the search name is in the email subject
        'If (InStr(1, olMailItem.Subject, olSubject, vbTextCompare) <> 0) Then
        If (InStr(1, olMailItem.Sender, olSender, vbTextCompare) <> 0) Then

            With olMailItem
                For j = 1 To .Attachments.Count
                    strName = .Attachments.Item(j).DisplayName

                    'check if file already exists
                    If Not Dir(sPathstr & "\" & strName) = vbNullString Then
                         strName = "(1)" & strName
                    Else
                    End If

                    If Err.Number <> 0 Then
                    Else
                        .Attachments(j).SaveAsFile sPathstr & "\" & strName

                    End If
                    Err.Clear
                    Set sh = Nothing
                    'wB.Close
                    On Error GoTo 0

                    h = h + 1
                Next j

            End With

        End If
    End If
Next i


Application.ScreenUpdating = True
MsgBox "Download complete!", vbInformation + vbOKOnly, "Done"

End Sub

标签： vbapdfoutlookadobe

解决方案

您可以硬编码EXE的路径，请参考以下代码：

   Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" _
   (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long

   Sub Test_Printpdf()
    Dim fn$
    fn = "C:\Users\Ken\Dropbox\Excel\pdf\p1.pdf"
    PrintPDf fn
   End Sub

Sub PrintPDf(fn$)
  Dim pdfEXE$, q$

  pdfEXE = ExePath(fn)
  If pdfEXE = "" Then
    MsgBox "No path found to pdf's associated EXE.", vbCritical, "Macro Ending"
    Exit Sub
  End If

  q = """"
  'http://help.adobe.com/livedocs/acrobat_sdk/10/Acrobat10_HTMLHelp/wwhelp/wwhimpl/common/html/wwhelp.htm?context=Acrobat10_SDK_HTMLHelp&file=DevFAQ_UnderstandingSDK.22.31.html
  '/s/o/h/p/t
  Shell q & pdfEXE & q & " /s /o /h /t " & q & fn & q, vbHide
End Sub

Function ExePath(lpFile As String) As String
   Dim lpDirectory As String, sExePath As String, rc As Long
   lpDirectory = "\"
   sExePath = Space(255)
   rc = FindExecutable(lpFile, lpDirectory, sExePath)
   sExePath = Left$(sExePath, InStr(sExePath, Chr$(0)) - 1)
  ExePath = sExePath
End Function

Sub Test_ExePath()
   MsgBox ExePath(ThisWorkbook.FullName)
End Sub

添加了用于查找路径的 API 方法，命令行参数不适用于较新的 Adob​​e Acrobat Reader DC。

有关更多信息，请参阅以下链接：

使用 VBA 代码打印文件

使用 VBA 打印 PDF 文件

推荐阅读