outlookメール 注意喚起のPOPUP

Private WithEvents myInspectors As Outlook.Inspectors

Private Sub Application_Startup()
    Set myInspectors = Application.Inspectors
End Sub

Private Sub myInspectors_NewInspector(ByVal Inspector As Inspector)
    On Error Resume Next
    Dim mail As Outlook.MailItem

    ' 開かれたアイテムがメールか確認
    If TypeName(Inspector.CurrentItem) = "MailItem" Then
        Set mail = Inspector.CurrentItem
        
        ' 件名に「！」または「‼」が含まれているか確認
        If InStr(mail.Subject, "！") > 0 Or InStr(mail.Subject, "‼") > 0 Then
            
            Dim result As VbMsgBoxResult
            result = MsgBox("件名に「！」または「‼」が含まれています。" & vbCrLf & _
                            "本当に開いてもよいですか？", _
                            vbYesNo + vbExclamation, "確認")
            
            ' No の場合、ウィンドウを閉じる
            If result = vbNo Then
                Inspector.Close olDiscard
            End If
        End If
    End If
End Sub