![如何让 Outlook 2010 自动打印附件?](https://linux22.com/image/1369083/%E5%A6%82%E4%BD%95%E8%AE%A9%20Outlook%202010%20%E8%87%AA%E5%8A%A8%E6%89%93%E5%8D%B0%E9%99%84%E4%BB%B6%EF%BC%9F.png)
我正在尝试让 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