使用单个宏运行多个宏，遇到编译错误

Question

正在尝试编写两个宏以在收到新电子邮件时自动打印附件，并且仅打印电子邮件的第一页。 代码如下所示：

Private Declare Function ShellExecute 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
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
  Dim Ns As Outlook.NameSpace
  Dim Folder As Outlook.MAPIFolder
  Set Ns = Application.GetNamespace("MAPI")
  Set Folder = Ns.GetDefaultFolder(olFolderInbox)
  Set Items = Folder.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
  If TypeOf Item Is Outlook.MailItem Then
    Printattachments Item
  End If
End Sub
Private Sub Printattachments(oMail As Outlook.MailItem)
  On Error Resume Next
  Dim colAtts As Outlook.Attachments
  Dim oAtt As Outlook.Attachment
  Dim sFile As String
  Dim sDirectory As String
  Dim sFileType As String
  sDirectory = "D:Attachments"
  Set colAtts = oMail.Attachments
  If colAtts.Count Then
    For Each oAtt In colAtts
' This code looks at the last 4 characters in a filename
      sFileType = LCase$(Right$(oAtt.FileName, 4))
      Select Case sFileType
' Add additional file types below
      Case "xlsx", "docx", ".pdf", ".doc", ".xls"

        sFile = sDirectory & oAtt.FileName
        oAtt.SaveAsFile sFile
        ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
      End Select
    Next
  End If
End Sub
Sub PrintOnePage()
    SendKeys "%F", False
    SendKeys "P"
    SendKeys "{TAB 2}", True
    SendKeys "{DOWN}", True
    SendKeys "1"
    SendKeys "{ENTER}"
End Sub
Sub RunAll()
    Call Printattachments
    Call PrintOnePage
End Sub

然后，我单击"常规"和"全部运行"，并遇到了编译错误：参数不是可选的。

任何意见将不胜感激！

Answer 1

您需要

做的是将PrintOnePage更改为

Public Sub PrintOnePage(ByVal Item As Object)
    SendKeys "%FPR"
    SendKeys "%S"
    SendKeys "1"
    SendKeys "{ENTER}"
End Sub

然后在您的项目添加事件上只需添加

Private Sub Items_ItemAdd(ByVal Item As Object)
  If TypeOf Item Is Outlook.MailItem Then
    Printattachments Item
    PrintOnePage Item '<-------- add
  End If
End Sub

请记住，现在，一旦您收到电子邮件，它将打印电子邮件正文的一页。

---

要仅打印带有附件的项目正文，请PrintOnePage Item移至

例

Private Sub Printattachments(ByVal Item As Outlook.MailItem)
    Dim colAtts As Outlook.Attachments
    Dim oAtt As Outlook.Attachment
    Dim sFile As String
    Dim sDirectory As String
    Dim sFileType As String
    sDirectory = "D:Attachments"
    Set colAtts = Item.Attachments
    If colAtts.Count Then
        For Each oAtt In colAtts
            ' This code looks at the last 4 characters in a filename
            sFileType = LCase$(Right$(oAtt.FileName, 4))
            Select Case sFileType
                ' Add additional file types below
                Case "xlsx", "docx", ".pdf", ".doc", ".xls"
                sFile = sDirectory & oAtt.FileName
                oAtt.SaveAsFile sFile
                ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
            End Select
        Next
    End If
    PrintOnePage Item '<-------- add
End Sub

---

_{Items.ItemAdd 事件 在将一个或多个项添加到指定的集合时发生。当一次将大量项目添加到文件夹中时，不会运行此事件。}

---

Answer 2

参考这篇文章，我会将您的 Subs 添加到此代码中(它转到 Sub RunAll 的位置(：

Private WithEvents Items As Outlook.Items 
Private Sub Application_Startup() 
  Dim olApp As Outlook.Application 
  Dim objNS As Outlook.NameSpace 
  Set olApp = Outlook.Application 
  Set objNS = olApp.GetNamespace("MAPI") 
  ' default local Inbox
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Items 
End Sub
Private Sub Items_ItemAdd(ByVal item As Object) 
  On Error Goto ErrorHandler 
  Dim Msg As Outlook.MailItem 
  If TypeName(item) = "MailItem" Then
    Set Msg = item 
    ' ******************
    Call Printattachments(Msg)
    Call PrintOnePage
    ' ******************
  End If
ProgramExit: 
  Exit Sub
ErrorHandler: 
  MsgBox Err.Number & " - " & Err.Description 
  Resume ProgramExit 
End Sub

重要

将所有

代码粘贴到ThisOutlookSession模块中。

这将在收到任何电子邮件后运行宏(需要重新启动 Outlook(。