Outlook VBA：自動で動作するマクロを作る(イベントマクロ)

' OutlookのVBAエディターでThisOutlookSessionに追加
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    ' 受信メールのIDコレクションを分割
    Dim arrEntryIDs() As String
    Dim EntryID As Variant
    arrEntryIDs = Split(EntryIDCollection, ",")
    
    ' 受信メールを確認
    Dim ns As Outlook.Namespace
    Dim itm As Outlook.MailItem
    Set ns = Application.GetNamespace("MAPI")
    
    For Each EntryID In arrEntryIDs
        Set itm = ns.GetItemFromID(EntryID)
        
        ' メールアイテムの場合
        If TypeName(itm) = "MailItem" Then
            ' 件名に「リリース情報」が含まれているか確認
            If InStr(itm.Subject, "リリース情報") > 0 Then
                ' メッセージボックスを表示
                MsgBox "件名に「リリース情報」が含まれたメールを受信しました。", vbInformation, "新しいメール"
            End If
        End If
    Next EntryID
End Sub

' OutlookのVBAエディターでThisOutlookSessionに追加
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    ' 受信メールのIDコレクションを分割
    Dim arrEntryIDs() As String
    Dim EntryID As Variant
    arrEntryIDs = Split(EntryIDCollection, ",")
    
    ' 受信メールを確認
    Dim ns As Outlook.Namespace
    Dim itm As Outlook.MailItem
    Dim destFolder As Outlook.Folder
    Set ns = Application.GetNamespace("MAPI")
    Set destFolder = ns.GetDefaultFolder(olFolderInbox).Folders("重要")
    
    For Each EntryID In arrEntryIDs
        Set itm = ns.GetItemFromID(EntryID)
        
        ' メールアイテムの場合
        If TypeName(itm) = "MailItem" Then
            ' 宛先に「sample@aaa.com」が含まれているか確認
            If InStr(itm.To, "sample@aaa.com") > 0 Then
                ' メールを「重要」フォルダに移動
                itm.Move destFolder
            End If
        End If
    Next EntryID
End Sub

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim arrEntryIDs() As String
    Dim EntryID As Variant
    arrEntryIDs = Split(EntryIDCollection, ",")
    
    Dim ns As Outlook.Namespace
    Dim itm As Outlook.MailItem
    Set ns = Application.GetNamespace("MAPI")
    
    For Each EntryID In arrEntryIDs
        Set itm = ns.GetItemFromID(EntryID)
        
        If TypeName(itm) = "MailItem" Then
            If itm.SenderEmailAddress = "sample@aaa.com" Then
                Call ExportMailToExcel(itm)
            End If
        End If
    Next EntryID
End Sub

Private Sub ExportMailToExcel(mail As Outlook.MailItem)
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim desktopPath As String
    Dim filePath As String
    
    ' デスクトップのパスを取得
    desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    filePath = desktopPath & "\important.xls"
    
    ' Excelアプリケーションを起動
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If xlApp Is Nothing Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    
    ' Excelファイルを開く
    Set xlWB = xlApp.Workbooks.Open(filePath)
    Set xlSheet = xlWB.Sheets(1)
    
    ' 最終行を取得して新しい行にデータを追加
    Dim lastRow As Long
    lastRow = xlSheet.Cells(xlSheet.Rows.Count, "B").End(-4162).Row + 1 ' -4162はxlUpの値
    
    ' メール情報をExcelに出力
    xlSheet.Cells(lastRow, 2).Value = mail.Subject
    xlSheet.Cells(lastRow, 3).Value = mail.ReceivedTime
    
    ' 保存してExcelを閉じる
    xlWB.Save
    xlWB.Close SaveChanges:=False
    xlApp.Quit
    
    ' オブジェクトの解放
    Set xlSheet = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
End Sub

' OutlookのVBAエディターでThisOutlookSessionに追加
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    ' 送信アイテムがメールの場合
    If TypeName(Item) = "MailItem" Then
        Dim mail As Outlook.MailItem
        Set mail = Item
        
        ' メッセージボックスを表示して、ユーザーの選択を確認
        Dim result As VbMsgBoxResult
        result = MsgBox("添付忘れない？送信してよい？", vbYesNo + vbQuestion, "メール送信確認")
        
        ' Noが選択された場合、送信をキャンセル
        If result = vbNo Then
            Cancel = True
            MsgBox "メールの送信がキャンセルされました。", vbInformation, "送信キャンセル"
        End If
    End If
End Sub