Kaydedilen PDF 'lerin Sıralı Bir Şekilde Mail Gönderilmesi

[huseyinn31]

Arkadaşlar merhaba,

Excelde hazırladığım tabloyu pdf olarak sicillere göre tüm çalışanlar için belirlediğim klasöre kaydedebiliyorum. Bireysel olarak mailde atabiliyorum ama tüm çalışanların tablosunu pdf olarak tek tıkla kaydettiğim gibi Mail Gönder 'e de 1 kere basınca otomatik olarak mailleri göndersin istiyorum. For next döngüsünü denedim ama yapamadım. Teşekkürler.

Sub Mail_Gonder()
Dim Makro As Object
Dim Mail As Object
Set Makro = CreateObject("Outlook.Application")
Set Mail = Makro.CreateItem(0)
Dim Mail_Adresi_From As String
Dim Mail_Adresi_To As String
Dim satir As String
Dim dosyaadi As String
Dim adisoyadi As String
Dim sicilno As String, epostaeki As String
Dim mailkonu As String

satir = Worksheets("MailAdresleri").Range("A:A").Find(Worksheets("BordroTasarimi").Range("K4").Value).Row
Mail_Adresi_To = Worksheets("MailAdresleri").Cells(satir, 3)
sicilno = Worksheets("MailAdresleri").Cells(satir, 1)
adisoyadi = Worksheets("MailAdresleri").Cells(satir, 2)
dosyaadi = "DosyaYolu" & sicilno & ".pdf"
mailkonu = Worksheets("BordroTasarimi").Range("C1")


epostaeki = Dir(dosyaadi)

If epostaeki <> "" Then
On Error Resume Next
With Mail
Set Mail.SendUsingAccount = Makro.Session.Accounts.Item(2)
Mail.To = Mail_Adresi_To
Mail.Subject = mailkonu
Mail.Body = "Sayın " & adisoyadi & "," & vbNewLine & vbNewLine
Mail.Body = Mail.Body & mailkonu & "nu ek'te bulabilirsiniz." & vbNewLine & vbNewLine
Mail.Body = Mail.Body & "Saygılarımızla," & vbNewLine
Mail.Body = Mail.Body & "Müdürlük İsmi"
Mail.Attachments.Add (dosyaadi)
Mail.Send
End With
On Error GoTo 0
Set Mail = Nothing
Set Makro = Nothing
End If

End Sub

 

[excelokyanus500]

Sayın huseyinn31 şayet tek bir dosyayı birden fazla kişiye gönderecekseniz :
"Mail_Adresi_To" hücresini tek bir hücre olarak belirleyin. Bu tek hücreye mail adreslerini
bir defaya mahsus olmak üzere örnek olarak veriyorum (adısoyadı@gmail.com;adısoyadı@gmail.com;adısoyadı@gmail.com) şeklinde girin.
İlgili kişilere ulaşacaktır.
Birden fazla ve farklı dosya için farklı bir mantık kurgulamak gerekir.
Bu bir örneğin Bordro maili şeklinde olacaksa o zaman

Sub SendMail()

    Dim objOutlook As Object
    Dim objMail As Object
    Dim ws As Worksheet
    Sheets("mail").Select
    Range("A1").Select
    Set objOutlook = CreateObject("Outlook.Application")
    Set ws = ActiveSheet

  For Each Cell In ws.Range("f2:f23") ' İsim listesi bölgesi

    Set objMail = objOutlook.CreateItem(0)

        With objMail
            .To = Cell.Value  '  Gidecek kişi
            .Subject = Cell.Offset(0, -3).Value ' Konu
            .Body = Cell.Offset(0, -4).Value & vbLf & Cell.Offset(0, -1).Value & vbLf & Cell.Offset(0, 2).Value & vbLf & "İyi Çalışmalar" & vbLf & vbLf & Cell.Offset(0, 3).Value ' İçerik
            .Attachments.Add Cell.Offset(0, 4).Value ' Bu hücrede dosyanın  tam yolu olmalı .Ve bu daha önceden o hücreye kayıt edilmeli
            .Display
            .Send
            ''.Display
Application.Wait (Now + TimeValue("0:00:03"))
Application.SendKeys "%s"
        End With

        Set objMail = Nothing
    Next Cell

    Set ws = Nothing
    Set objOutlook = Nothing


End Sub

 

[huseyinn31]

Sayın huseyinn31 şayet tek bir dosyayı birden fazla kişiye gönderecekseniz :
"Mail_Adresi_To" hücresini tek bir hücre olarak belirleyin. Bu tek hücreye mail adreslerini
bir defaya mahsus olmak üzere örnek olarak veriyorum (adısoyadı@gmail.com;adısoyadı@gmail.com;adısoyadı@gmail.com) şeklinde girin.
İlgili kişilere ulaşacaktır.
Birden fazla ve farklı dosya için farklı bir mantık kurgulamak gerekir.
Bu bir örneğin Bordro maili şeklinde olacaksa o zaman

Sub SendMail()

    Dim objOutlook As Object
    Dim objMail As Object
    Dim ws As Worksheet
    Sheets("mail").Select
    Range("A1").Select
    Set objOutlook = CreateObject("Outlook.Application")
    Set ws = ActiveSheet

  For Each Cell In ws.Range("f2:f23") ' İsim listesi bölgesi

    Set objMail = objOutlook.CreateItem(0)

        With objMail
            .To = Cell.Value  '  Gidecek kişi
            .Subject = Cell.Offset(0, -3).Value ' Konu
            .Body = Cell.Offset(0, -4).Value & vbLf & Cell.Offset(0, -1).Value & vbLf & Cell.Offset(0, 2).Value & vbLf & "İyi Çalışmalar" & vbLf & vbLf & Cell.Offset(0, 3).Value ' İçerik
            .Attachments.Add Cell.Offset(0, 4).Value ' Bu hücrede dosyanın  tam yolu olmalı .Ve bu daha önceden o hücreye kayıt edilmeli
            .Display
            .Send
            ''.Display
Application.Wait (Now + TimeValue("0:00:03"))
Application.SendKeys "%s"
        End With

        Set objMail = Nothing
    Next Cell

    Set ws = Nothing
    Set objOutlook = Nothing


End Sub

Bordro maili atacağım için her kişiye tek mail ve tek dosya gönderilecek hocam. Kısa bir göz gezdirdim kodu çözmeye çalışacağım.