VBA-展望。循环浏览每封具有特定主题的电子邮件,以保存最新收到的电子邮件中的附件。如果没有收到附件,请转到下一封电子邮件

问题描述 投票:0回答:0

VBA-展望。循环浏览每封具有特定主题的电子邮件,以保存最新收到的电子邮件中的附件。如果没有收到附件,请转到下一封电子邮件。

下面的代码运行良好,但几天后出现错误“类不支持自动化或不支持预期的接口。”

我只需要针对上述错误的解决方案或有关可以在编码中进行的任何修改的任何建议。

所以我的要求是 (1) 保存收到的带有特定主题名称的电子邮件附件 (2) 邮箱应该是最新的邮箱 (3) 邮件应该有附件,如果没有去最新的带有附件的特定主题名称的邮件。


Sub Save_Raw_Data_From_Email()

Dim App As Outlook.Application
Dim My_Folder As Outlook.MAPIFolder
Dim NS As Outlook.Namespace
Dim Attachments As Outlook.Attachments
Dim i As Long
Dim IngCount As Long
Dim File As String
Dim Sub1, Sub2, Sub3 As String
Dim Items As Outlook.Items
Dim Item As Object
Dim Atmt As Object

''''''Dim Msg As Outlook.MailItem
''''''Dim Item As Items

Dim FileName As String
Dim Path1 As String


Path1 = "C:\Users\" & Environ("UserName") & "\" & "Downloads" & "\" & "Attachments" & "\"

LR = ThisWorkbook.Sheets("Main").Cells(Rows.Count, 2).End(xlUp).Row
For j = 1 To LR
Sub1 = ThisWorkbook.Sheets("Main").Range("B" & j).Value


Set App = New Outlook.Application
Set NS = App.GetNamespace("MAPI")
'''''''''Set My_Folder = NS.GetDefaultFolder(olFolderInbox).Folders("Test_Folder")
Set My_Folder = NS.GetDefaultFolder(olFolderInbox)
Set Items = My_Folder.Items

Items.Sort Property:="[ReceivedTime]", Descending:=True
Path1 = Path1

     
For Each Item In My_Folder.Items
For Each Atmt In Item.Attachments
If Item.Subject Like "*" & Sub1 & "*" And Atmt Like "*.xls*" Then
Set Attachments = Item.Attachments
IngCount = Attachments.Count
End If
Next
Next

If IngCount > 0 Then
For i = IngCount To 1 Step -1
If Attachments.Item(i).FileName Like "*.xls*" Then
File = Attachments.Item(i).FileName
File = Path1 & File
Attachments.Item(i).SaveAsFile File

End If
Next
End If
Next



Set Attachments = Nothing
Set Msg = Nothing
Set My_Folder = Nothing
Set NS = Nothing

End Sub

vba loops outlook email-attachments
© www.soinside.com 2019 - 2024. All rights reserved.