Outlook toplu mail göndermde hata

[acar6783]

Hayırlı akşamlar,
Aşağıdaki kodlarda sayfada mail adresleri bulunan kişilere mail atmak istiyorum fakat ne hikmetse hatayı bir türlü çözemedim.
İlk satırdaki kişiye mail gidiyor sonraki döngüde "Öğe taşınmış yada silinmiş" hatası geliyor (kırmızı renkli satırda debug )

Kodların çalıştığına eminim çünkü tek tek mail atabiliyorum . Döngü girince hata veriyor.

Option Explicit

Dim yol As String
Dim Dosya_Adi As String
Dim Outlook_App As Object
Dim Outlook_Mail As Object
Dim cl As Worksheet, Onay As Byte
Dim sat
Dim pdfdosya
Sub toplu_MAIL_GONDER()
    Set Outlook_App = CreateObject("Outlook.Application")
    Set Outlook_Mail = Outlook_App.CreateItem(0)
    
   Set cl = Sheets("CariListesi")
'On Error Resume Next
For sat = 5 To cl.Cells(Rows.Count, "A").End(3).Row
If cl.Cells(sat, "E") <> "" And cl.Cells(sat, "G") <> "" Then

    pdfdosya = cl.Cells(sat, "G")
yol = ThisWorkbook.Path & "\Gönderilmiş\" & cl.Cells(sat, "B")

    Dosya_Adi = yol & "\" & pdfdosya
    ChDir yol

        
        With Outlook_Mail
            [COLOR="Red"][B].To = cl.Cells(sat, "E")[/B][/COLOR]
         
            .CC = cl.Cells(sat, "F")
            .BCC = cl.Cells(3, "B")
            .Subject = cl.Cells(1, "B")
            .Body = "Merhaba Sayın Yetkili," & vbCrLf & "" & vbCrLf _
            & cl.Cells(5, "C") & " Tarihli Mutabakat formu  ekte bilgilerinize sunulmuştur." & vbCrLf & vbCrLf & _
                    "Mutabık olduğunuza dair imzalı kaşeli görselini tarafımıza göndermeniz rica olunur" _
                    & vbCrLf & "Saygılarımla" & vbCrLf & "İyi çalışmalar dileriz."
            .Attachments.Add Dosya_Adi & ".pdf"
            .BodyFormat = 2
            .Save
            .OriginatorDeliveryReportRequested = True
            .ReadReceiptRequested = True
            .Send
            '.Display
        End With
        
            End If
Next sat
        MsgBox sat - 5 & " Firmaya mail Gönderilmiştir.", vbInformation
     
    Set cl = Nothing
    Set Outlook_Mail = Nothing
    Set Outlook_App = Nothing
End Sub

 

[askm]

Örnek dosya üzerinden bakarsak daha iyi olacak. Belirttiğiniz gibi normalde makro çalışıyor. Ama dosyanızdan bakmak gerekli.

 

[antonio]

Merhaba,
Kodların verdiği hatanın sebebini anlamak için örnek dosyanızı görmek daha doğru olur.
Kodlarınızda belirtilen verilerin sayfanızda ilgili hücrelerde yer aldığını varsayıyorum. Bu durumda kodlarınızda aşağıda gösterdiğim yazım adabına dikkat etmenizi tavsiye ederim (.Value) ifadesi yok iken, hücreyi işaret eder. Belirtilen ifade eklendikten sonra, hücre içindeki değeri ifade eder. Ayrıca .Save satırını devre dışı bıraktım.
Aşağıdaki şekilde düzeltme yaptıktan sonra dönüş yapınız.

Option Explicit

Dim yol As String
Dim Dosya_Adi As String
Dim Outlook_App As Object
Dim Outlook_Mail As Object
Dim cl As Worksheet, Onay As Byte
Dim sat
Dim pdfdosya
Sub toplu_MAIL_GONDER()
    Set Outlook_App = CreateObject("Outlook.Application")
    Set Outlook_Mail = Outlook_App.CreateItem(0)
    
   Set cl = Sheets("CariListesi")
'On Error Resume Next
For sat = 5 To cl.Cells(Rows.Count, "A").End(3).Row
If cl.Cells(sat, "E")[COLOR="Red"][B].Value[/B][/COLOR] <> "" And cl.Cells(sat, "G")[COLOR="red"][B].Value[/B][/COLOR] <> "" Then

    pdfdosya = cl.Cells(sat, "G").Value
yol = ThisWorkbook.Path & "\Gönderilmiş\" & cl.Cells(sat, "B")[COLOR="red"][B].Value[/B][/COLOR]

    Dosya_Adi = yol & "\" & pdfdosya
    ChDir yol

        
        With Outlook_Mail
            .To = cl.Cells(sat, "E")[COLOR="red"][B].Value[/B][/COLOR]
         
            .CC = cl.Cells(sat, "F")[COLOR="red"][B].Value[/B][/COLOR]
            .BCC = cl.Cells(3, "B")[COLOR="red"][B].Value[/B][/COLOR]
            .Subject = cl.Cells(1, "B")[COLOR="red"][B].Value[/B][/COLOR]
            .Body = "Merhaba Sayın Yetkili," & vbCrLf & "" & vbCrLf _
            & cl.Cells(5, "C")[COLOR="red"].Value[/COLOR] & " Tarihli Mutabakat formu  ekte bilgilerinize sunulmuştur." & vbCrLf & vbCrLf & _
                    "Mutabık olduğunuza dair imzalı kaşeli görselini tarafımıza göndermeniz rica olunur" _
                    & vbCrLf & "Saygılarımla" & vbCrLf & "İyi çalışmalar dileriz."
            .Attachments.Add Dosya_Adi & ".pdf"
            .BodyFormat = 2
[COLOR="Red"][B]'            .Save[/B][/COLOR]
            .OriginatorDeliveryReportRequested = True
            .ReadReceiptRequested = True
            .Send
            '.Display
        End With
        
            End If
Next sat
        MsgBox sat - 5 & " Firmaya mail Gönderilmiştir.", vbInformation
    Set cl = Nothing
    Set Outlook_Mail = Nothing
    Set Outlook_App = Nothing
End Sub

 

[acar6783]

Sorunumu çözdüm .

Farklı bir yöntem denedim oldu...

İlgilenen arkadaşlar olursa buradan paylaşabilirim

 

[acar6783]

Dim App As New Outlook.Application
Dim Exp As Outlook.Explorer
Dim Sel As Outlook.Items
Dim AttachmentCnt As Integer
Dim AttTotal As Integer
Dim MsgTotal As Integer
Dim outputDir As String
Dim outputFile As String
Dim fileExists As Boolean
Dim cnt As Integer
Dim fso As FileSystemObject

Set Exp = App.ActiveExplorer

[COLOR="Red"]Set Sel = Exp.CurrentFolder.Items[/COLOR]
Set fso = New FileSystemObject

Farklı bir kod fakat konu bütünlüğü bozulmazın diye yine buradanyazıyorum.
Outlook açık olunca sorun yok fakat kapalı olunca yuarıdaki Kırmızı boyalı satır hata veriyor.
Kapalı dediğim normalde kodlardan da anlaşılacağı üzere alt bömlümde acılıyor.
Alternatif ne kod yazabilirim?

 

[acar6783]

Merhaba,
Kodların verdiği hatanın sebebini anlamak için örnek dosyanızı görmek daha doğru olur.
Kodlarınızda belirtilen verilerin sayfanızda ilgili hücrelerde yer aldığını varsayıyorum. Bu durumda kodlarınızda aşağıda gösterdiğim yazım adabına dikkat etmenizi tavsiye ederim (.Value) ifadesi yok iken, hücreyi işaret eder. Belirtilen ifade eklendikten sonra, hücre içindeki değeri ifade eder. Ayrıca .Save satırını devre dışı bıraktım.
Aşağıdaki şekilde düzeltme yaptıktan sonra dönüş yapınız.

Msajınızı şimdi gördüm
askm MEsajını görmüştüm sadece ben yazarken.
Fakat kodları denedim yine aynı satıra hata verdi malesef