Outlook VBA - 附加文件夹中的所有文件

Question

我想扩展我创建的 Outlook 宏。一位客户希望每周通过一封电子邮件发送发票附件，而我们的系统目前无法支持。我已将系统设置为将所有发票发送给我，以便我可以将它们附加到一封电子邮件中。

我创建的宏将我的电子邮件中的所有附件从特定的 outlook 文件夹保存到我计算机上的特定文件夹中。然后它起草了一封电子邮件供我发送给我的客户。

我需要的下一步是让宏获取所有保存的文件并将它们附加到起草的电子邮件中，然后从我计算机上的文件夹中删除文件。

以下是我目前的代码：

Dim ol As Outlook.Application
    Dim ns As Outlook.NameSpace
    Dim fol As Outlook.MAPIFolder
    Dim i As Object
    Dim mi As Outlook.MailItem
    Dim at As Outlook.Attachment
    
    Set ol = New Outlook.Application
    Set ns = ol.GetNamespace("MAPI")
    Set fol = ns.GetDefaultFolder(olFolderInbox)
    Set fol = fol.Folders("_CLIENT INVOICES")
    
    For Each i In fol.Items
    
        If i.Class = olMail Then
        
            Set mi = i
            
            If mi.Attachments.Count > 0 Then
                
                For Each at In mi.Attachments
                
                    If Right(at.FileName, 3) = "pdf" Then
                
                        at.SaveAsFile "C:\Users\MYNAME\OneDrive\CLIENT Invoices\" & at.FileName
                            
                    End If
                    
                Next at
                
            End If
            
        End If
    
    Next i
    
    'Drafting Email

    Dim outlookapp As Object
    Dim outlookmessage As Object

    Set outlookapp = GetObject(Class:="Outlook.Application")
    Set outlookmessage = outlookapp.CreateItem(0)

   With outlookmessage
    .SentOnBehalfOfName = "OUR EMAIL"
    .To = "CLIENT EMAIL"
    .Subject = "Invoices"
    .Body = "Dear Valued Client," & vbNewLine & vbNewLine & "Attached please find the invoices for       
    services provided." & vbNewLine & vbNewLine & "Thank you,"
    .Display
    End With
    On Error GoTo 0

    Set outlookmessage = Nothing
    Set outlookapp = Nothing
            
    
    End Sub

Answer 1

首先，不需要在代码中创建和检索一个Outlook

Application

实例。发现了以下几行代码：

Set ol = New Outlook.Application

但稍后发送电子邮件时会重新检索实例：

Set outlookapp = GetObject(Class:="Outlook.Application")

其次，在文件夹中处理项目时，所有附件都保存到同一文件夹中：

For Each at In mi.Attachments
  If Right(at.FileName, 3) = "pdf" Then
    at.SaveAsFile "C:\Users\MYNAME\OneDrive\CLIENT Invoices\" & at.FileName
  End If
Next at

同名文件有可能保存到同一个文件夹，所以已经保存的文件可以被覆盖。我建议在文件名中添加任何 ID，不要依赖附件的

FileName

属性。例如，您可以考虑使用 RecievedTime 属性值。

第三，要附加文件夹中的所有文件，您可以使用以下代码：

Dim fso As Object
Dim fsFolder As Object
Dim fsFile As Object

Set fso = CreateObject("Scripting.FileSystemObject")
Set fsFolder = fso.GetFolder(strFolder)

For Each fsFile In fsFolder.Files
   If fsFile.Name Like "*.pdf" Then
      .Attachments.Add strFolder & "\" & fsFile.Name  
   End If
Next