☰

如何让 Outlook 2010 自动打印附件？

tag-icon • tag-icon microsoft-outlook printing vba
如何让 Outlook 2010 自动打印附件？

我正在尝试让 Outlook 2010 在附件到达时自动打印。

我发现这在网上。VBA 代码是

Sub LSPrint(Item As Outlook.MailItem)  
    On Error GoTo OError

    'detect Temp
    Dim oFS As FileSystemObject
    Dim sTempFolder As String
    Set oFS = New FileSystemObject
    'Temporary Folder Path
    sTempFolder = oFS.GetSpecialFolder(TemporaryFolder)

    'creates a special temp folder
    cTmpFld = sTempFolder & "\OETMP" & Format(Now, "yyyymmddhhmmss")
    MkDir (cTmpFld)

    'save & print
    Dim oAtt As Attachment
    For Each oAtt In Item.Attachments
      FileName = oAtt.FileName
      FullFile = cTmpFld & "\" & FileName

      'save attachment
      oAtt.SaveAsFile (FullFile)

      'prints attachment
      Set objShell = CreateObject("Shell.Application")
      Set objFolder = objShell.NameSpace(0)
      Set objFolderItem = objFolder.ParseName(FullFile)
      objFolderItem.InvokeVerbEx ("print")

    Next oAtt

    'Cleanup
    If Not oFS Is Nothing Then Set oFS = Nothing
    If Not objFolder Is Nothing Then Set objFolder = Nothing
    If Not objFolderItem Is Nothing Then Set objFolderItem = Nothing
    If Not objShell Is Nothing Then Set objShell = Nothing

  OError:
    If Err <> 0 Then
      MsgBox Err.Number & " - " & Err.Description
      Err.Clear
    End If
    Exit Sub

  End Sub

我允许运行宏。我将代码粘贴到 VBA 编辑器中的 ThisOutlookSession 中，并添加了对 Microsoft Scripting Runtime 的引用。我创建了一条规则，检查新邮件是否来自我，如果是，则运行脚本。我向自己发送了一封带有 .doc 附件的邮件，收到后收到错误消息“424 - 需要对象”。

我家里没有打印机（我需要其他地方的代码），所以我将 Microsoft XPS Writer 设置为默认打印机，只是为了看看它是否能正常工作。这是错误的原因吗？如果不是，那是什么原因，我该如何修复它？

最重要的是，我该如何完成工作？我需要使用 VBA 脚本（而不是插件），而且我是 VBA 新手。

我现在正在使用 Windows XP，但我需要这个东西能在 Windows 7 上运行。

答案1

将以下代码粘贴到ThisOutlookSession。

根据需要编辑代码，然后单击Application_Startup()宏并按“运行”按钮 (F8)。这样无需重新启动 Outlook 即可启动宏。

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 olNameSpace As Outlook.NameSpace
    Dim Folder As Outlook.MAPIFolder

    Set olNameSpace = Application.GetNamespace("MAPI")
    Set Folder = olNameSpace.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(olItem As Outlook.MailItem)
    On Error Resume Next
    Dim colAtts As Outlook.Attachments
    Dim olAtt As Outlook.Attachment
    Dim sFile As String
    Dim sDirectory As String
    Dim sFileType As String

    sDirectory = "C:\Attachments"

    Set colAtts = olItem.Attachments

    If colAtts.Count Then
        For Each olAtt In colAtts
        '// List file types -
        sFileType = LCase$(Right$(olAtt.FileName, 4))

        Select Case sFileType
            Case ".xls", ".doc"
            sFile = ATTACHMENT_DIRECTORY & olAtt.FileName
            olAtt.SaveAsFile sFile
            ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
            End Select
        Next
    End If
End Sub

请参阅自动打印附件

相关内容