特定の送信者からの添付ファイルをDwonload添付してExcelで開く

Question

私はむしろVBAを初めて使っていて、プロジェクトに助けを求めていました。あなたにいくつかの背景を与えるために、私は約15分ごとにOutlookで添付ファイルを添付して電子メールを受け取ります。電子メールが届くと添付ファイルを開き、それを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 

を。

次に、2つ以上のファイルを作成したら、Excelで別のマクロを使用してファイルを読み込んで2つのファイルを比較し、矛盾があれば電子メールで送信できます。

あなたが始めることを望みます。

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