Question

我对VBA很新，希望能得到一些项目的帮助。为了给你一些背景知识，我通过excel附件每15分钟收到一封关于outlook的电子邮件。我需要在电子邮件进入后打开附件并查看/将其与15分钟前发送的电子邮件进行比较。如果电子邮件存在差异，那么我必须执行一项操作。我希望至少自动化一些这个过程。理想情况下，我可以使用宏来扫描我的收件箱中是否有来自特定发件人的任何新邮件。如果它找到了一条消息，那么它可以检查附件，如果附件在那里，它将下载并打开它。

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

非常感谢任何帮助。正如我所说，我是VBA的新手，但我正在尽力理解功能。

Answer 1

这应该让你开始。假设您在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

Answer 2

有趣的问题，我将开始介绍outlook部分。您可能希望在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中的另一个宏加载文件并比较这两个文件，如果有任何差异，则发送电子邮件。

希望能让你开始。

Dwonload来自特定发件人的附件并在excel

2 个答案: