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
            ' Action if subject condition is met
            MsgBox "Alert: Subject contains specified keywords - " & Email.Subject, vbExclamation, "Subject Alert"
                        
            ' Execute any application (e.g., playsound.exe)
            'Call RunAny("D:\Sound_Alert\error_log_batch.exe")
            Call PlayAlertSound
        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
        
        ' Uncomment this section if you want to check both conditions together
        ' If CheckSenderAndSubject(email) Then
        '     MsgBox "Alert: Both conditions met for email - " & email.Subject, vbInformation, "Combined 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("test")
    
    ' 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 check if the sender equals "xxxx@gmail.com"
' Private Function CheckSenderEmail(ByVal email As Outlook.MailItem) As Boolean
'     If email.SenderEmailAddress = "xxxx@gmail.com" Then
'         CheckSenderEmail = True
'     Else
'         CheckSenderEmail = False
'     End If
' End Function

' Function to check both subject and sender conditions together
' Private Function CheckSenderAndSubject(ByVal email As Outlook.MailItem) As Boolean
'     If CheckSenderEmail(email) And CheckSubject(email) Then
'         CheckSenderAndSubject = True
'     Else
'         CheckSenderAndSubject = False
'     End If
' End Function

' Function to run any application or batch file
Private Sub RunAny(ByVal filePath As String)
    Dim ret As Long
    ret = Shell(filePath, vbNormalFocus) ' Corrected: used filePath parameter instead of undefined RunAnyPath
        ' Optional: Show result of Shell command
    'If ret = 0 Then
    '    MsgBox "Failed to run: " & filePath
    'Else
    '    MsgBox "Successfully triggered: " & filePath
    'End If
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 = "C:\path\to\your\Saved Emails\" ' 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
    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 call saveemail