Option Explicit
    
    'SpamFilter v1.6
    '(C) Quatro Solutions, 2018
    'www.quatrosolutions.co.uk

'Limit number of lines from top to check ...
Const MaxLines = 100

Private WithEvents Items As Outlook.Items
Private WithEvents Items2 As Outlook.Items

Private Sub Application_Startup()
    Dim olNs As Outlook.NameSpace
    Dim Inbox  As Outlook.MAPIFolder
    Dim Inbox2  As Outlook.MAPIFolder
    Dim Acc As Outlook.Account
    Dim Acc2 As Outlook.Account

    'Assign ctrl-j to junk an email in single key-stroke

    Set olNs = Application.GetNamespace("MAPI")
    Set Acc = olNs.Accounts("andrew.gordon@quatrosolutions.co.uk")
    Set Acc2 = olNs.Accounts("agordon@qsol.co.uk")
    Set Inbox = Acc.DeliveryStore.GetDefaultFolder(olFolderInbox)
    Set Inbox2 = Acc2.DeliveryStore.GetDefaultFolder(olFolderInbox)
    
    'MsgBox "Outlook opened & with " & Inbox.Items.Restrict("[Unread] = true").Count & " unread items in " & Acc.DisplayName & ":" & Inbox.Name & ".", vbOKOnly, "SpamFilter"
    Set Items = Inbox.Items.Restrict("[Unread] = true")
    'MsgBox "Outlook opened & with " & Inbox2.Items.Restrict("[Unread] = true").Count & " unread items in " & Acc2.DisplayName & ":" & Inbox2.Name & ".",vbOKOnly, "SpamFilter"
    Set Items2 = Inbox2.Items.Restrict("[Unread] = true")
End Sub

Public Sub Items_ItemAdd(ByVal myItem As Object)
    If TypeOf myItem Is Outlook.MailItem Then
        Find_Spam myItem
        Find_Facebook myItem
    End If
End Sub

Public Sub Items2_ItemAdd(ByVal myItem As Object)
    If TypeOf myItem Is Outlook.MailItem Then
        Find_Spam myItem
        Find_Facebook myItem
    End If
End Sub

Private Sub Find_Spam(ByVal myItem As Object)
    Dim strAddr1 As String
    Dim strAddr2 As String
    Dim rcpReplies As Outlook.Recipients
    Dim rcpReply As Outlook.Recipient
    
    
    ' Look for specific patterns
    If TypeName(myItem) = "MailItem" Then
    
        'Leave LinkedIn stuff
        strAddr1 = myItem.SenderEmailAddress
        If InStr(1, strAddr1, "linkedin") = 0 Then
        
            'Look for where Sender on envelope <> From on mail
            If myItem.ReplyRecipients.Count > 0 Then
                Set rcpReplies = myItem.ReplyRecipients
                Set rcpReply = rcpReplies(1)
                strAddr2 = rcpReply.Address
                If Trim(strAddr1) <> Trim(strAddr2) Then
                    MoveItemToSpam myItem
                End If
            Else
                                    
                'MsgBox "New mail received from " & strAddr1 & ".",vbOKOnly, "SpamFilter"
                Select Case True
                    Case strAddr1 Like "*@mail##*"
                        'MsgBox "Spam mail received from " & strAddr1 & ".",vbOKOnly, "SpamFilter"
                        MoveItemToSpam myItem
                    Case strAddr1 Like "*@?mail##*"
                        'MsgBox "Spam mail received from " & strAddr1 & ".",vbOKOnly, "SpamFilter"
                        MoveItemToSpam myItem
                   Case strAddr1 Like "*@multi##*"
                        'MsgBox "Spam mail received from " & strAddr1 & ".",vbOKOnly, "SpamFilter"
                        MoveItemToSpam myItem
                    Case strAddr1 Like "*@emailaddicts##*"
                        'MsgBox "Spam mail received from " & strAddr1 & ".",vbOKOnly, "SpamFilter"
                        MoveItemToSpam myItem
                    Case strAddr1 Like "*.info"
                        'MsgBox "Spam mail received from " & strAddr1 & ".",vbOKOnly, "SpamFilter"
                        MoveItemToSpam myItem
                    Case strAddr1 Like "*.online"
                        'MsgBox "Spam mail received from " & strAddr1 & ".",vbOKOnly, "SpamFilter"
                        MoveItemToSpam myItem
                End Select
            End If
        End If
    End If
End Sub

Private Sub MoveItemToSpam(ByVal myItem As Object)
    On Error GoTo FAIL

    Dim myDestFolder As Outlook.Folder
    Set myDestFolder = Application.GetNamespace("MAPI").Folders("andrew.gordon@quatrosolutions.co.uk").Folders("Junk") ' or Spam
    myItem.Move myDestFolder
    
    Exit Sub
FAIL:
    'Ignore errors. Item may have already been moved due to other SPAM rules.
    Exit Sub
End Sub

Private Sub MoveItemToFB(ByVal myItem As Object)
    On Error GoTo FAIL

    Dim myDestFolder As Outlook.Folder
    Set myDestFolder = Application.GetNamespace("MAPI").Folders("andrew.gordon@quatrosolutions.co.uk").Folders("Facebook") ' or Spam
    myItem.Move myDestFolder
    
    Exit Sub
FAIL:
    'Ignore errors. Item may have already been moved due to other SPAM rules.
    Exit Sub
End Sub

Private Sub Find_Facebook(ByVal myItem As Object)
    Dim lsSender As String
    ' Your Code here
    If TypeName(myItem) = "MailItem" Then
        lsSender = myItem.SenderEmailAddress
        'MsgBox "New mail received from " & lsSender & "."
        Select Case True
            Case lsSender Like "*@facebook*"
                'MsgBox "Facebook mail received from " & lsSender & ".",vbOKOnly, "SpamFilter"

                MoveItemToFB myItem
        End Select
    End If
End Sub

Public Sub Junk_Item()
    '(C) Quatro Solutions, 2018
    'www.quatrosolutions.co.uk
    
    On Error GoTo FAIL
    
    Dim Session As Outlook.NameSpace
    Dim CurrentExplorer As Explorer
    Dim Selection As Selection
    Dim ItemSubject As String
    Dim ItemSubjects As New Collection
    Dim ItemNo As Integer
   
    Dim JunkItem As Outlook.MailItem

    'MsgBox "Running Junk_Item"

    Set CurrentExplorer = Application.ActiveExplorer
    Set Selection = CurrentExplorer.Selection

    Select Case Selection.Count
    Case 1      'Single item select is straightforward
        'MsgBox "Junking single item."
        SendKeys "+{F10}JB^{HOME}", True
        Exit Sub
    Case Is > 1
        For Each JunkItem In Selection
            'MsgBox "Junking item " & JunkItem.Subject & " from " & JunkItem.SenderEmailAddress, vbOKOnly, "SpamFilter"
            ItemSubjects.Add JunkItem.EntryID, JunkItem.EntryID
        Next
    Case Else
    End Select

       
    Select Case MsgBox("Do you wish to mark these " & Str(ItemSubjects.Count) & " items as Spam?", vbOKCancel, "SpamFilter")
    Case vbOK
    Case Else
        Exit Sub
    End Select
    
    'Now loads of SendKeys because stupid Outlook VBA doesn't expose the methods necessary to Junk selected items,
    'or even ability to highlight specific items in the GUI by EntryID so we can send a simple "+{F10}JB" for each one
     
     'Go to top of list
    SendKeys "{HOME}", True
    DoEvents
    
    Select Case CurrentExplorer.Selection.Count
    Case 0
        MsgBox "No item selected"
    Case 1
        ItemSubject = ""
        For ItemNo = 1 To MaxLines
            'Select current line
            Set Selection = CurrentExplorer.Selection
            For Each JunkItem In Selection
                'Check if we got 'stuck' on last item
                If ItemSubject = JunkItem.EntryID Then SendKeys "{Down}"
                If IsInCollection(JunkItem.EntryID, ItemSubjects) Then
                    'MsgBox "Junking item " & JunkItem.Subject & " from " & JunkItem.SenderEmailAddress
                    ItemSubject = JunkItem.EntryID
                    SendKeys "+{F10}", True
                    SendKeys "J", True
                    SendKeys "B", True
                    DoEvents
                    'Remove Item from Collection
                    ItemSubjects.Remove ItemSubject
                    If ItemSubjects.Count = 0 Then GoTo ENDSUB
                Else
                    SendKeys "{DOWN}", True
                    DoEvents
                End If
            Next
        Next
    Case Else
        MsgBox "Multiple items still selected. Junk will not work on multiple items.", vbOKOnly, "SpamFilter"
    End Select
    
    
ENDSUB:
    'Now keep going to the end
    On Error Resume Next
    
    Set Session = Nothing
    Set CurrentExplorer = Nothing
    Set JunkItem = Nothing
    Set Selection = Nothing
    Set ItemSubjects = Nothing
    
    SendKeys "{HOME}", True
    DoEvents
        
    Exit Sub
FAIL:
    MsgBox "Junk item failed: " & Error, vbOKOnly, "SpamFilter"
    
    
End Sub

Private Function IsInCollection(key As String, arr As Collection) As Boolean
    Dim obj As Variant
    On Error GoTo FAIL
    IsInCollection = True
    obj = arr(key)
    Exit Function
FAIL:
    IsInCollection = False
End Function

Public Sub CheckForSpam()
    On Error GoTo FAIL
    
    Dim CurrentExplorer As Explorer
    Dim Selection As Selection
    Dim JunkItem As Outlook.MailItem

    Set CurrentExplorer = Application.ActiveExplorer
    Set Selection = CurrentExplorer.Selection
    
    For Each JunkItem In Selection
        Find_Spam JunkItem
    Next JunkItem
    
    Set CurrentExplorer = Nothing
    Set JunkItem = Nothing
    Set Selection = Nothing
    
    Exit Sub

FAIL:
    MsgBox "Scan for spam failed." & Error, vbOKOnly, "SpamFilter"
    Exit Sub
End Sub

Public Sub TestMailItem()
    On Error GoTo FAIL
    
    Dim CurrentExplorer As Explorer
    Dim Selection As Selection
   
    Dim JunkItem As Outlook.MailItem

    Set CurrentExplorer = Application.ActiveExplorer
    Set Selection = CurrentExplorer.Selection
    
    For Each JunkItem In Selection
        If JunkItem.ReplyRecipients.Count > 0 Then
            MsgBox "Sender: " & JunkItem.Sender & "  SenderEmailAddress: " & JunkItem.SenderEmailAddress & "  ReplyToAddress: " & JunkItem.ReplyRecipients(1).Address
        Else
            MsgBox "Sender: " & JunkItem.Sender & "  SenderEmailAddress: " & JunkItem.SenderEmailAddress & "  ReplyToAddress: None"
        End If
    Next JunkItem
    
    Set CurrentExplorer = Nothing
    Set JunkItem = Nothing
    Set Selection = Nothing
    
    Exit Sub

FAIL:
    MsgBox "Test mail failed: " & Error, vbOKOnly, "SpamFilter"
    Exit Sub
End Sub