我的VBA技能非常有限，但我已经走了这么远，现在我想完成这个项目。
我有下面的VBA代码在我的展望中工作得很好。它将所需的电子邮件保存到我的驱动器中。
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")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
'Change variables to match need. Comment or delete any part unnecessary.
If (Msg.SenderEmailAddress = "noreply@test.com") Or _
(Msg.Subject = "Smartsheet") Or _
(Msg.Subject = "Defects") And _
(Msg.Attachments.Count >= 1) Then
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As String
'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "C:"
' save attachment
Set myAttachments = item.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att
' mark as read
Msg.UnRead = False
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.number & " - " & Err.Description
Resume ProgramExit
End Sub
我现在想在附件保存到我的测试文件夹后，将代码添加到移动电子邮件。测试文件夹在我的outlook中的收件箱下。
我添加了Set FldrDest = Session.Folders("Address1").Folders("Inbox").Folders("Test")
在私有子应用程序启动((下，然后我将代码添加到VBA中。
代码在'标记后为已读
If .Parent.Name = "Test" And .Parent.Parent.Name = "Inbox" Then
' MailItem is already in destination folder
Else
.Move FldrDest
End If
没有其他更改，但它给了我编译错误。
MailItem.Move实际上是一个函数，它返回在新目标中移动的对象。旧对象有点"丢失"，看看如何使用它(我已经在整个代码;)中评论了删除部分(
Set Msg = .Move(FldrDest)
MsgBox Msg.SenderEmailAddress & vbCrLf & Msg.Subject
完整的代码和一些改进建议(见'-->评论(：
Private WithEvents Items As Outlook.Items
'location to save in. Can be root drive or mapped network drive.
'-->As it is a constant you can declare it there (and so, use it in the whole module if you want to do other things with it!)
Private Const attPath As String = "C:"
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
'Only act if it's a MailItem
If TypeName(item) = "MailItem" Then
Dim Msg As Outlook.MailItem
'-->Use directly the parameter and keep it under wraps using "With", it'll improve efficiency
With item
'Change variables to match need. Comment or delete any part unnecessary.
If (.SenderEmailAddress = "noreply@test.com" _
Or .Subject = "Smartsheet" _
Or .Subject = "Defects" _
) _
And .Attachments.Count >= 1 Then
Dim aAtt As Outlook.Attachment
'-->Loop through the Attachments' collection
for each aAtt in item.Attachments
'-->You can either use aAtt.DisplayName or aAtt.FileName
'-->You can test aAtt.Size or aAtt.Type
'save attachment
aAtt.SaveAsFile attPath & aAtt.DisplayName
next aAtt
'mark as read
.UnRead = False
Dim olDestFldr As Outlook.MAPIFolder
Set FldrDest = Session.Folders("Address1").Folders("Inbox").Folders("Test")
If .Parent.Name = "Test" And .Parent.Parent.Name = "Inbox" Then
'MailItem is already in destination folder
Else
Set Msg = .Move(FldrDest)
MsgBox Msg.SenderEmailAddress & vbCrLf & Msg.Subject
'Msg.delete
End If
End If
End With 'item
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.number & " - " & Err.Description
Resume ProgramExit
End Sub
比我想象的要容易。刚刚添加了一个带有Msg.Delete.的循环