从Outlook收件箱中下载Excel相关附件，并使用VBA将其保存在基于日期范围的特定文件夹中? &

Question

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

2. 所有下载的附件保存到桌面文件夹

3. 当我运行下面的代码时，它从outlook下载所有附件并保存在我的文档文件夹中。

   Const sPath As String = "C:UsersDocumentsAttachments"
   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
   

Answer 1

我已经修改了你的代码，以获得附件中文件的扩展名，然后检查它是否是xl文件。你能试着运行代码，让我知道，如果你有任何疑问。谢谢。

Const sPath As String = "C:UsersDocumentsAttachments"
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

Answer 2

请尝试运行以下修改后的代码。

我对代码做了以下修改:

1)。现在可以在代码本身中添加起始日期和到日期范围。所有收到日期在指定范围内的电子邮件都将被保存为附件。

2)。现在所有xl文件和CSV文件都可以保存了。

Const sPath As String = "C:UsersDocumentsAttachments"
Sub saveAttachments()
Dim ns As namespace
Dim Inbox As MAPIFolder, SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim FileFullName As String
Dim blnxlFile As Boolean
Dim intPos As Integer
Dim strExtn As String
Dim FromDate As Date
Dim ToDate As Date, DtEmailDate As Date
Dim blnDate As Boolean
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)

FromDate = #5/2/2020#   'Change the from Date here
ToDate = #5/31/2020#    ' Change the To date here

On Error Resume Next
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
blnxlFile = False
blnDate = 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" Or Left(strExtn, 2) = "csv" Then
blnxlFile = True
DtEmailDate = DateValue((Format(Item.ReceivedTime, "DD/MM/YYYY")))
End If
End If

If DtEmailDate >= FromDate And DtEmailDate <= ToDate Then
blnDate = True
End If

If blnxlFile = True And blnDate = True Then
FileFullName = sPath & Format(Item.ReceivedTime, "DDMMYYYY") & "_" & Format(Now, "DDMMYYHHMMSS") & FileName
Atmt.SaveAsFile FileFullName ' sPath & FileName
End If
Next Atmt
Next Item
MsgBox "Download Complete.", vbInformation, "SUCCESS"
End Sub

Answer 3

我在循环中做了一些修改，并测试了代码。它只需要那些与日期标准匹配的电子邮件，然后检查附件是否与xl和csv文件扩展名匹配。希望代码现在应该以应有的方式工作。谢谢! !

Const sPath As String = "C:UsersDocumentsAttachments"
Sub saveAttachments()
Dim ns As namespace
Dim Inbox As MAPIFolder, SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim FileFullName As String
Dim blnxlFile As Boolean
Dim intPos As Integer
Dim strExtn As String
Dim FromDate As Date
Dim ToDate As Date, DtEmailDate As Date
Dim blnDate As Boolean
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)

FromDate = #5/2/2020#   'Change the from Date here
ToDate = #5/31/2020#    ' Change the To date here

On Error Resume Next
For Each Item In Inbox.Items
blnDate = False
DtEmailDate = DateValue((Format(Item.ReceivedTime, "DD/MM/YYYY")))
If DtEmailDate >= FromDate And DtEmailDate <= ToDate Then
blnDate = True
End If

If blnDate = True Then
For Each Atmt In Item.Attachments
blnxlFile = False
strExtn = ""
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") Or (Left(strExtn, 3) = "csv") Then
blnxlFile = True
End If
End If
If blnxlFile = True Then
FileFullName = sPath & Format(Item.ReceivedTime, "DDMMYYYY") & "_" & Format(Now, "DDMMYYHHMMSS") & FileName
Atmt.SaveAsFile FileFullName ' sPath & FileName
End If
Next Atmt
End If
Next Item
MsgBox "Download Complete.", vbInformation, "SUCCESS"
End Sub