Dwonload从特定的发件人附件，并在Excel中打开

我对VBA相当陌生，希望能在项目上得到一些帮助。 为了给大家提供一些背景知识，每隔15分钟我会收到一封电子邮件，内容是Excel附件。 我需要打开附件，一旦电子邮件进入并查看它/比较它在15分钟前发送的电子邮件。 如果电子邮件有所不同，那么我必须采取行动。 我希望能够自动化至less一些这个过程。 理想情况下，我可以使用macros来扫描我的收件箱中是否有来自特定发件人的新邮件。 如果它发现一条消息，它可以检查附件，如果附件在那里，它会下载并打开它。

在一个理想的世界中，我能做的另一件事就是将先前的excel附件与当前的附件进行比较，如果不同，则可以ping一条消息（警报）。

任何帮助将非常感激。 正如我所说，我是VBA新手，但我正在尽我所能去理解函数。

Answer 1

这应该让你开始。 假设你已经selectOutlook中的电子邮件：

Sub check_for_changes() 'Created by Fredrik Östman www.scoc.se Dim myOlApp As New Outlook.Application Dim myOlExp As Outlook.Explorer Dim myOlSel As Outlook.Selection Set myOlExp = myOlApp.Explorers.Item(1) Set myOlSel = myOlExp.Selection Set mymail = myOlSel.Item(1) Dim myAttachments As Outlook.Attachments Set myAttachments = mymail.Attachments Dim Atmt As Attachment Set Atmt = myAttachments(1) new_file_name = "C:\tmp\new_received_file.xlsx" old_file_name = "C:\tmp\old_received_file.xlsx" FileCopy new_file_name, old_file_name Atmt.SaveAsFile new_file_name Dim eApp As Object Set eApp = CreateObject("Excel.Application") eApp.Application.Visible = True Dim new_file As Object eApp.workbooks.Open new_file_name Set new_file = eApp.ActiveWorkbook Dim old_file As Object eApp.workbooks.Open old_file_name Set old_file = eApp.ActiveWorkbook 'Find range to compare start_row = old_file.sheets(1).usedrange.Row If new_file.sheets(1).usedrange.Row > start_row Then start_row = new_file.sheets(1).usedrange.Row end_row = old_file.sheets(1).usedrange.Row + old_file.sheets(1).usedrange.Rows.Count If new_file.sheets(1).usedrange.Rows.Count + new_file.sheets(1).usedrange.Row > end_row Then end_row = new_file.sheets(1).usedrange.Rows.Count + new_file.sheets(1).usedrange.Row start_col = old_file.sheets(1).usedrange.Column If new_file.sheets(1).usedrange.Column > start_col Then start_col = new_file.sheets(1).usedrange.Column end_col = old_file.sheets(1).usedrange.Column + old_file.sheets(1).usedrange.Columns.Count If new_file.sheets(1).usedrange.Columns.Count + new_file.sheets(1).usedrange.Column > end_row Then end_row = new_file.sheets(1).usedrange.Columns.Count + new_file.sheets(1).usedrange.Column 'Check all cells something_changed = False For i = start_row To end_row For j = start_col To end_col If new_file.sheets(1).Cells(i, j) <> old_file.sheets(1).Cells(i, j) Then new_file.sheets(1).Cells(i, j).Interior.ColorIndex = 3 'Mark red something_changed = True End If Next j Next i If something_changed Then new_file.Activate Else new_file.Close old_file.Close If eApp.workbooks.Count = 0 Then eApp.Quit MsgBox "No changes" End If End Sub 

Answer 2

有趣的问题，我会让你开始与前景部分。 你可能会想分开Outlook和Excel之间的问题。

以下是我用来保存每个附件的代码，我已经在Outlook中发送以节省空间。

 Public Sub SaveAttachments() Dim objOL As Outlook.Application Dim pobjMsg As Outlook.MailItem 'Object Dim objSelection As Outlook.Selection On Error Resume Next ' Instantiate an Outlook Application object. Set objOL = CreateObject("Outlook.Application") ' Get the collection of selected objects. Set objSelection = objOL.ActiveExplorer.Selection For Each pobjMsg In objSelection SaveAttachments_Parameter pobjMsg Next ExitSub: Set pobjMsg = Nothing Set objSelection = Nothing Set objOL = Nothing MsgBox "Export Complete" End Sub Public Sub SaveAttachments_Parameter(objMsg As MailItem) Dim objAttachments As Outlook.Attachments Dim i As Long Dim lngCount As Long Dim strFile As String Dim strFolderpath As String Dim strDeletedFiles As String ' Get the path to your My Documents folder strFolderpath = "C:\Users\******\Documents\Reports\" 'On Error Resume Next ' Set the Attachment folder. strFolderpath = strFolderpath & "Outlook Attachments\" ' Get the Attachments collection of the item. Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count If lngCount > 0 Then ' We need to use a count down loop for removing items' from a collection. Otherwise, the loop counter gets' confused and only every other item is removed. For i = lngCount To 1 Step -1 ' Save attachment before deleting from item. ' Get the file name. strFile = objAttachments.Item(i).FileName If Right(strFile, 4) = ".png" Or Right(strFile, 4) = ".jpg" Or Right(strFile, 4) = ".gif" Then GoTo cont End If ' Combine with the path to the Temp folder. strFile = strFolderpath & objMsg.SenderName & "." & Format(objMsg.ReceivedTime, "yyyy-MM-dd h-mm-ss") & "." & strFile ' Save the attachment as a file. objAttachments.Item(i).SaveAsFile strFile ' Delete the attachment - You might not want this part 'objAttachments.Item(i).Delete 'write the save as path to a string to add to the message 'check for html and use html tags in link If objMsg.BodyFormat = olFormatHTML Then strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & Replace(strFile, " ", "%20") & ">" Else strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & Replace(strFile, " ", "%20") & ">" End If cont: Next i ' Adds the filename string to the message body and save it ' Check for HTML body If objMsg.BodyFormat = olFormatHTML Then objMsg.Body = "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body Else objMsg.HTMLBody = "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.HTMLBody End If objMsg.Save End If ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objOL = Nothing End Sub 

代码中的部分说

  If Right(strFile, 4) = ".png" Or Right(strFile, 4) = ".jpg" Or Right(strFile, 4) = ".gif" Then GoTo cont 

你可以改变成这样的：

  If objMsg.SenderName = "John Smith" Then GoTo cont 

这样它将只保存该特定发件人的附件。

然后，一旦你有两个或更多的文件，你可以使用Excel中的另一个macros加载文件，并比较这两个文件，然后发送电子邮件，如果有任何差异。

希望能让你开始。