Outlook Otomatik CC Makrosu

Bulunduğum şirkette Outlook üzerinde mail gönderirken gönderen bilgisine göre CC bilgisini değiştirip firmaya ait bir maili CC içerisinde eklememiz gerekiyor. Bende gönderen bilgisine göre otomatik cc ekleyen bir makro yazdım, belirli alanları değiştirerek sizlerde kullanabilirsiniz.

Class içerisine eklenecek kod:

Public WithEvents mItem As Outlook.MailItem

Private Sub mItem_Open(Cancel As Boolean)
    Call CCKontrol
End Sub

Private Sub mItem_PropertyChange(ByVal Name As String)
    Call CCKontrol
End Sub

Sub CCKontrol()
    On Error Resume Next
    Dim strSender As String
    Dim strCC As String
    Dim objRecip As Recipient
    Dim recipientExists As Boolean

    If Not mItem.SendUsingAccount Is Nothing Then
        strSender = mItem.SendUsingAccount.SmtpAddress
    End If
    
    If strSender = "" Or InStr(1, strSender, "outlook", vbTextCompare) > 0 Then
        If mItem.SentOnBehalfOfName <> "" Then strSender = mItem.SentOnBehalfOfName
    End If
    
    strSender = LCase(strSender)
    
    strCC = ""
    If InStr(strSender, "mehmet@leventemre.com") > 0 Then
        strCC = "ahmet@leventemre.com"
    ElseIf InStr(strSender, "ahmet@leventemre.com") > 0 Then
        strCC = "mehmet@leventemre.com"
    End If

    If strCC = "" Then Exit Sub

    recipientExists = False
    For Each objRecip In mItem.Recipients
        If LCase(objRecip.Address) = strCC Or LCase(objRecip.Name) = strCC Then
            recipientExists = True
            Exit For
        End If
    Next objRecip

    If Not recipientExists Then
        Set objRecip = mItem.Recipients.Add(strCC)
        objRecip.Type = olCC
        objRecip.Resolve
    End If
End Sub

ThisWorkBook içerisine eklenecek kod:

Dim WithEvents objInspectors As Outlook.Inspectors
Dim objMailList As Collection

Private Sub Application_Startup()
    Set objInspectors = Application.Inspectors
    Set objMailList = New Collection
    MsgBox "Oto-CC Sistemi Aktif!", vbInformation
End Sub

Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
    Dim objMailWatcher As cMailTakip
    
    If Inspector.CurrentItem.Class = olMail Then
        Set objMailWatcher = New cMailTakip
        Set objMailWatcher.mItem = Inspector.CurrentItem
        
        objMailList.Add objMailWatcher
    End If
End Sub

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim tempWatcher As New cMailTakip
    If Item.Class = olMail Then
        Set tempWatcher.mItem = Item
        tempWatcher.CCKontrol
    End If
End Sub

Eklediğim kod içerisindeki işlem mail mehmet@leventemre.com üzerinden gönderilirse otomatik ahmet@leventemre.com mail adresi CC alanına ekleniyor, aynı şekilde eğer ahmet@leventemre.com mail gönderen ise mehmet@leventemre.com otomatik CC alanına ekleniyor.

İyi çalışmalar.