Outlook tan makro ile otomatik mail gönderme

[KARTAL133]

Merhaba

Outlookten otomatik olarak cevplamak için bir makro yazdım.
müşterin mail adreslerini k koluna maüşteri maillerin @ sonraki uzntılarını yazdım
mailde gelen göre sorgulama yapıp G kolunda bulunan mail adreslerini ekleyip ilgili kişilere mail göndermesi için makro yazdım
hatayı bulamadım
Yardımcı olmanızı rica ederim.





Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim mailItem As Object
Dim entryID As Variant
Dim ns As Outlook.NameSpace
Dim sourceFolder As Outlook.Folder
Dim targetFolder As Outlook.Folder
Dim excelPath As String
Dim foundRow As Range
Dim senderDomain As String
Dim targetEmail As String

' Excel dosya yolunu belirtin
excelPath = "C:\Path\To\musteri_listesi.xlsx"

' Outlook Namespace nesnesi
Set ns = Application.GetNamespace("MAPI")

' Gelen kutusu klasörünü belirtin
Set sourceFolder = ns.GetDefaultFolder(olFolderInbox)

' Taşıma klasörünü oluşturun veya bulun
On Error Resume Next
Set targetFolder = ns.GetDefaultFolder(olFolderInbox).Folders("Otomatik Cevaplama")
If targetFolder Is Nothing Then
Set targetFolder = ns.GetDefaultFolder(olFolderInbox).Folders.Add("Otomatik Cevaplama")
End If
On Error GoTo 0

' Yeni mailleri döngü ile kontrol et
For Each entryID In Split(EntryIDCollection, ",")
Set mailItem = Application.Session.GetItemFromID(entryID)

' Gönderen domainini al
senderDomain = Split(mailItem.SenderEmailAddress, "@")(1)

' Excel uygulamasını başlat
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Open(excelPath)
Set xlSheet = xlWB.Sheets(1)

' Domaini Excel'de ara
On Error Resume Next
Set foundRow = xlSheet.Columns("D").Find(What:=senderDomain, LookIn:=xlValues, LookAt:=xlWhole)
On Error GoTo 0

If Not foundRow Is Nothing Then
targetEmail = xlSheet.Cells(foundRow.Row, "K").Value

' Yeni mail oluştur
Dim replyMail As Outlook.mailItem
Set replyMail = mailItem.ReplyAll
replyMail.CC = targetEmail
replyMail.Body = "Merhaba, konu ile ilgili kişiye yardımcı olmanızı rica ederim." & vbCrLf & replyMail.Body
replyMail.Send

' Maili okunmuş olarak işaretle
mailItem.UnRead = False

' Maili taşı
mailItem.Move targetFolder
End If

' Excel dosyasını kapat
xlWB.Close False
xlApp.Quit

' Nesneleri serbest bırak
Set xlSheet = Nothing
Set xlWB = Nothing
Set xlApp = Nothing
Next entryID

' Nesneleri serbest bırak
Set mailItem = Nothing
Set ns = Nothing
Set sourceFolder = Nothing
Set targetFolder = Nothing
End Sub

 

[KARTAL133]

Yardımcı olacak kişi var arkadaşlar