触发运行 Outlook 宏

Question

有没有一种方法，每当我收到一封发送到 Outlook 中特定文件夹的电子邮件时，Outlook 会自动运行一个宏（为了澄清一下，电子邮件会发送到那里，因为我已经设置了一个规则，所以不是转到我的收件箱转到该文件夹​​）。

我想我需要能够检测我的文件夹何时收到新电子邮件然后自动运行宏的代码。

我的代码如下，我执行测试，执行SaveEmailAttachmentsToFolder.

Sub Test()

'Arg 1 = Folder name of folder inside your Inbox 'Arg 2 = File extension, "" is every file 'Arg 3 = Save folder, "C:\Users\Ron\test" or "" ' If you use "" it will create a date/time stamped folder for you in your "Documents" folder ' Note: If you use this "C:\Users\Ron\test" the folder must exist.

SaveEmailAttachmentsToFolder "Dependencia Financiera", "xls", "V:\Dependencia Financiera\Dependencia Financiera\"

End Sub

Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _ ExtString As String, DestFolder As String)

Dim ns As NameSpace
Dim Inbox As Folder
Dim SubFolder As Folder

Dim subFolderItems As Items

Dim Atmt As Attachment

Dim FileName As String

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)

Set subFolderItems = SubFolder.Items

If subFolderItems.Count > 0 Then

    subFolderItems.Sort "[ReceivedTime]", True

    For Each Atmt In subFolderItems(1).Attachments
        If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
            FileName = DestFolder & Atmt.FileName
            Atmt.SaveAsFile FileName
        End If
    Next Atmt

End If

' Clear memory ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set subFolderItems = Nothing

End Sub

seulberg1 告诉我如何使用以下代码，我应该粘贴我自己的代码，因为它有 2 个 Subs。

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup() Dim olApp As Outlook.Application

Set olApp = Outlook.Application Set Items = GetNS(olApp).GetDefaultFolder(olFolderInbox).Folders("YourFolderName").Items End Sub

Private Sub Items_ItemAdd(ByVal item As Object)

On Error GoTo ErrorHandler

'Add your code here

ProgramExit: Exit Sub ErrorHandler: MsgBox Err.Number & " - " & Err.Description Resume ProgramExit End Sub

Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace Set GetNS = app.GetNamespace("MAPI") End Function

提前谢谢你！！！

Answer 1

这段代码（改编自 Jimmy Pena）应该可以解决问题。

它在 Outlook 启动时启动事件侦听器并检查文件夹“您的文件夹名称”是否有新电子邮件。然后它在（“在此处添加您的代码”）部分执行可指定的操作。

如果这有帮助，请告诉我

最好的问候 苏尔伯格1

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
  Dim olApp As Outlook.Application

  Set olApp = Outlook.Application
  Set Items = GetNS(olApp).GetDefaultFolder(olFolderInbox).Folders("YourFolderName").Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)

  On Error GoTo ErrorHandler

   **'Add your code here**

ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub

Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
  Set GetNS = app.GetNamespace("MAPI")
End Function