Dwonload從特定的發件人附件，並在Excel中打開

Question

我對VBA頗爲陌生，並希望得到一些項目的幫助。爲了給大家提供一些背景知識，每隔15分鐘我會收到一封電子郵件，內容是Excel附件。我需要打開附件，一旦電子郵件進入並查看它/將其與15分鐘前發送的電子郵件進行比較。如果電子郵件存在差異，我必須採取行動。我希望能夠自動化至少一些這個過程。理想情況下，我可以使用宏來掃描我的收件箱中是否有來自特定發件人的新郵件。如果它發現一條消息，它可以檢查附件，如果附件存在，它會下載並打開它。

在理想的世界中，我可以做的其他事情是將先前的excel附件與當前的附件進行比較，如果不同，則可以ping一條消息（警報）。

任何幫助將不勝感激。正如我所說，我是VBA新手，但我正在盡我所能理解功能。

Answer 1

有趣的問題，我會讓你開始與前景部分。你可能會想分開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中使用另一個宏加載文件，並比較這兩個文件，然後如果有差異發送給你一封電子郵件。

希望能讓你開始。

Answer 2

這應該讓你開始。假設您已選擇Outlook中的電子郵件：

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