excel - 从 Outlook 收件箱下载 Excel 相关附件并使用 VBA 根据日期范围将其保存在特定文件夹中？

Question

1. 在这里，我想根据日期范围从 Outlook 应用程序下载所有与 Excel 相关的附件。

2. 所有下载的附件都将其保存在桌面文件夹中。

3. 当我运行以下代码时，它会从 Outlook 下载所有附件并保存在 mydocuments 文件夹中。

    Const sPath As String = "C:\Users\Documents\Attachments\"
   
    Sub Shortage_Attachments3()
    Dim ns As Namespace
    Dim Inbox As MAPIFolder, SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
   
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
   
    On Error Resume Next
   
    For Each Item In Inbox.Items
        For Each Atmt In Item.Attachments
            FileName = Atmt.FileName
            If Len(dir(sPath & FileName)) > 0 Then FileName = sPath & Format(Item(I).ReceivedTime, "DDMMYYYY") & "_" & Format(Now, "DDMMYYHHMMSS") & FileName
                Atmt.SaveAsFile FileName
        Next Atmt
      Next Item
   
    MsgBox "Download Complete.", vbInformation, "SUCCESS"
   
    End Sub
   

标签： excelvbaoutlook

Answer 1

我已经修改了您的代码以获取附件中文件的扩展名，然后检查它是否是 xl 文件。您能否尝试运行代码，如果您有任何疑问，请告诉我。谢谢。

Const sPath As String = "C:\Users\Documents\Attachments\"

 Sub Shortage_Attachments3()
 Dim ns As namespace
 Dim Inbox As MAPIFolder, SubFolder As MAPIFolder
 Dim Item As Object
 Dim Atmt As Attachment
 Dim FileName As String
 Dim blnxlFile As Boolean
 Dim intPos As Integer
 Dim strExtn As String

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

 On Error Resume Next

 For Each Item In Inbox.Items
     For Each Atmt In Item.Attachments
         blnxlFile = False
         FileName = Atmt.FileName
         intPos = InStr(1, FileName, ".", vbTextCompare)
         If intPos > 0 Then
            strExtn = Mid(FileName, intPos + 1, Len(FileName) - intPos)
            If Left(strExtn, 2) = "xl" Then
                blnxlFile = True
            End If
         End If
         If Len(Dir(sPath & FileName)) > 0 And blnxlFile = True Then
            FileName = sPath & Format(Item(i).ReceivedTime, "DDMMYYYY") & "_" & Format(Now, "DDMMYYHHMMSS") & FileName
            Atmt.SaveAsFile FileName
         End If
     Next Atmt
   Next Item

 MsgBox "Download Complete.", vbInformation, "SUCCESS"

 End Sub