Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
    Dim Inbox As Outlook.Folder
    Set Inbox = Application.Session.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
        Dim Email As Outlook.MailItem
        Set Email = Item
        
        ' Check individual conditions
        If CheckSubject(Email) Then
        
            ' Execute any application (e.g., playsound.exe or run bat)
            ' Call RunAny("cmd.exe /c D:\Sound_Alert\run-task.bat")
            ' Call RunAny("cmd /c D:\Sound_Alert\error_log_batch.exe")
        
            ' Action if subject condition is met
            ' MsgBox "Alert: Subject contains specified keywords - " & Email.Subject, vbExclamation, "Subject Alert"
            
        End If
        
        ' Uncomment this section if you want to check the sender's email
        ' If CheckSenderEmail(Email) Then
        '     MsgBox "Alert: Sender is 'xxxx@gmail.com' - " & Email.Subject, vbExclamation, "Sender Alert"
        ' End If
    End If
End Sub

' Function to check if the subject contains all specified keywords (case-insensitive)
Private Function CheckSubject(ByVal Email As Outlook.MailItem) As Boolean
    Dim keywords As Variant
    Dim keyword As Variant
    Dim allKeywordsFound As Boolean
    
    ' Initialize the flag as True
    allKeywordsFound = True
    
    ' Array of keywords to search for
    keywords = Array("logbatch")
    
    ' Loop through each keyword and check if it exists in the subject
    For Each keyword In keywords
        ' Use InStr with vbTextCompare for case-insensitive search
        If InStr(1, Email.Subject, keyword, vbTextCompare) = 0 Then
            allKeywordsFound = False ' Set flag to False if any keyword is not found
            Exit For ' No need to check further, exit the loop
        End If
    Next keyword
    
    ' Return the status of all keywords found
    CheckSubject = allKeywordsFound
End Function

' Function to run any application or batch file
Private Sub RunAny(ByVal filePath As String)
    Dim processID As Long
    Dim processHandle As Long
    Dim waitResult As Long
    
    ' Start the process
    processID = Shell(filePath, vbNormalFocus)

End Sub

Private Sub SaveEmailAsMsg(ByVal Email As Outlook.MailItem)
    Dim SaveFolderPath As String
    Dim fileName As String

    ' Set the folder where you want to save the .msg files
    SaveFolderPath = "D:\SavedEmails\" ' Change to your desired path

    ' Ensure the folder exists
    If Dir(SaveFolderPath, vbDirectory) = "" Then
        MsgBox "The specified folder does not exist: " & SaveFolderPath
        Exit Sub
    End If

    ' Create a filename using the received time and subject
    fileName = SaveFolderPath & Format(Email.ReceivedTime, "yyyymmdd_hhnn_") & _
                CleanFileName(Email.Subject) & ".msg"

    ' Save the email as a .msg file
    Email.SaveAs fileName, olMSG
    ' Mark the email as read (this might be meant to be set to False)
    Email.UnRead = False
End Sub

Private Function CleanFileName(str As String) As String
    ' Replace invalid filename characters with underscores
    Dim InvalidChars As Variant
    Dim i As Long
    InvalidChars = Array(":", "\", "/", "*", "?", """", "<", ">", "|")
    
    For i = LBound(InvalidChars) To UBound(InvalidChars)
        str = Replace(str, InvalidChars(i), "_")
    Next i
    
    CleanFileName = str
End Function



how to prevent excute all older email when new open outlook program