从主题中包含特定文本的传入电子邮件中保存Excel附件

Question

如果主题包含"；我的电话；保存Excel文件。

由于更新，我不能再使用"；运行脚本"；Outlook规则的选项。我还没能用VBA检查主题中"我的电话"的所有电子邮件，然后运行脚本。

Private Sub SaveAttachments(Item As Outlook.MailItem)
If Item.Attachments.Count > 0 Then
Dim EmAttach As Outlook.Attachments 
Dim AttachCount As Long 
Dim EmAttFile As String 
Dim sFileType As String 
Dim i As Long
Set EmAttach = Item.Attachments AttachCount = EmAttach.Count
For i = AttachCount To 1 Step -1
'Get the file name. 
EmAttFile = EmAttach.Item(i).FileName
If LCase(Right(EmAttFile, 5)) = ".xlsx" Then
'Get the path to your My Documents folder 
DestFolderPath = CreateObject("WScript.Shell").SpecialFolders(16) DestFolderPath = DestFolderPath & "Attachments"
'Combine with the path to the folder. 
EmAttFile = DestFolderPath & EmAttFile
'Save the attachment as a file. 
EmAttach.Item(i).SaveAsFile EmAttFile 
End If 
Next i 
End If
End Sub

我需要这个代码来自动工作。我收到35多个电子表格，其中有一个代理人完成的电话列表。这些数据必须保存在一个固定的位置(他们无权访问(，这样另一张工作表才能将数据提取到仪表板中。

Answer 1

所以我最近想按照与您想要实现的类似的方式自动保存一些pdf附件。我设置它的方式是有一个子文件夹，我可以对收到的电子邮件应用过滤规则，将我想从中提取pdf的电子邮件隔离到这个文件夹中。使用VBA，您可以拾取新电子邮件并处理附件。

以下代码是我目前使用的，因此需要进行调整以供使用，但显示了的一般方法

在"ThisOutlookSession"模块内

Private WithEvents ReportItems As Outlook.Items
Private Sub Application_Startup()
On Error Resume Next
With Outlook.Application
Set ReportItems = .GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("PDFData").Items
End With
End Sub
Private Sub ReportItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
If TypeName(Item) = "MailItem" Then Call SavePDFAttachmentReports(Item, "C:Reports")
End Sub

在模块内

Sub SavePDFAttachmentReports(ByVal Item As Object, FilePath As String)
Dim i As Long, FileName As String
If Right(FilePath, 1) <> "" Then FilePath = FilePath & ""

With Item.Attachments
If .Count > 0 Then
For i = 1 To .Count
FileName = FilePath & .Item(i).FileName
If LCase(Right(FileName, 3)) = "pdf" Then
FileName = Left(FileName, Len(FileName) - 4) & " Reverse Phase Report.pdf"
.Item(i).SaveAsFile FileName
End If
Next i
End If
End With
End Sub

改编(未经测试(：

Private WithEvents ReportItems As Outlook.Items
Private Sub Application_Startup()
On Error Resume Next
With Outlook.Application
Set ReportItems = .GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Excel Reports").Items
End With
End Sub
Private Sub ReportItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
If TypeName(Item) = "MailItem" Then Call _
SaveXLSXAttachments(Item, Environ("USERPROFILE") & "My DocumentsAttachments")
End Sub
Sub SaveXLSXAttachments(ByVal Item As Object, FilePath As String)
Dim i As Long, FileName As String
If Right(FilePath, 1) <> "" Then FilePath = FilePath & ""
With Item.Attachments
If .Count > 0 Then
For i = 1 To .Count
FileName = FilePath & .Item(i).FileName
'Debug.Print FileName
If LCase(Right(FileName, 5)) = ".xlsx" Then .Item(i).SaveAsFile FileName
Next i
End If
End With
End Sub