Vba 触发以运行outlook宏

是否有一种方式，每当我收到一封发往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个子代码

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

提前谢谢你

这段代码（改编自Jimmy Pena）应该可以做到这一点

它在Outlook启动时启动事件侦听器，并检查文件夹“Your folder Name”中的新电子邮件。然后在（“在此处添加代码”）部分执行可指定操作

如果有帮助，请告诉我

致意 瑟尔伯格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

这段代码（改编自Jimmy Pena）应该可以做到这一点

它在Outlook启动时启动事件侦听器，并检查文件夹“Your folder Name”中的新电子邮件。然后在（“在此处添加代码”）部分执行可指定操作

如果有帮助，请告诉我

致意 瑟尔伯格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

---

嗨，瑟伯格，非常感谢你的帮助，但我需要你再帮我一次。我应该如何粘贴我自己的代码，我已经用我自己的代码编辑了我的问题，所以你可以更好地帮助我。多谢各位！嗨，瑟伯格，非常感谢你的帮助，但我需要你再帮我一次。我应该如何粘贴我自己的代码，我已经用我自己的代码编辑了我的问题，所以你可以更好地帮助我。多谢各位！