Question

每次收到主题为“测试”的电子邮件时，我都希望：

自动提取所有附件并将其存储在其自己的新创建的文件夹中。
自动将电子邮件复制到新文件夹中
自动在此新文件夹中添加Word文档。
该文件夹必须以收到的日期命名。

我拥有的代码将所有附件复制到一个预先选择的文件夹中，但是没有为它们创建个人文件夹。

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.Subject = "Heures") And _
        (Msg.Attachments.Count >= 1) Then

    'Set folder to save in.
    Dim olDestFldr As Outlook.MAPIFolder
    Dim myAttachments As Outlook.Attachments
    Dim Att As Variant

    Const attPath As String = "C:\Users\NASC02\Test\"

    ' save attachment
    Set myAttachments = item.Attachments
    For Each Att In myAttachments
    Att.SaveAsFile attPath & Att.FileName

Next

    ' mark as read
   Msg.UnRead = False



End If
End If


ProgramExit:
  Exit Sub

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

Answer 1

代码

Set myAttachments = item.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att

需要更改为

Set myAttachments = item.Attachments
for each Att in myAttachments 
    Att.SaveAsFile attPath & Att.FileName
next

将附件保存到新的Windows文件夹？

1 个答案: