Excel ile Outlook'u kullanarak e-mail gönderme

Believing · 31 Mart 2021

Sayın Uzman arkadaşlar,

Excel ile Outlook'u kullanarak ekteki örnekteki gibi e-mail gönderiyorum.
Bu örnek çalışmaya iki senaryo daha eklemek istiyorum.
"Gönder" simgesine bastığımda mevcut kod sadece "SETTINGS" sayfasını PDF formatında göndermektedir.
Mail olarak gönderilecek sayfalar "DATA_RZV", "DATA_CAN", "DATA_AGE" şeklinde belirlenmiştir.
"LICENSE", "TEMPLATE", "PARAMETRE", "SETTINGS" isimli sayfalar mail olarak gönderilmeyecektir.
Outlook'taki kurumsal imzanın gönderilecek mail metninin sonuna eklenmesi mümkün müdür?
Mümkünse mevcut kodu nasıl revize etmeliyim?
Benim için çok kıymetli olan yardımlarınızı rica ediyorum.

Saygılarımla.

Örnek Çalışma Linki:

E-Mail_Gonder.rar dosyasını indir - download

E-Mail_Gonder.rar dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

ÖmerFaruk · 9 Nisan 2021

Sizin kodlarınızda ufak bir değişiklik yaptım. Deneyin lütfen

C++:

Sub AttachActiveSheetPDF()
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Dim Sh As Worksheet
    ' Not sure for what the Title is
    Title = Range("H20")
    
    ' Eğer sizin kodlarınız düzgün çalışıyorsa bu da çalışır.
    ' Use already open Outlook if possible
    On Error Resume Next
    Set OutlApp = GetObject(, "Outlook.Application")
    If Err Then
        Set OutlApp = CreateObject("Outlook.Application")
        IsCreated = True
    End If
    OutlApp.Visible = True
    On Error GoTo 0
    ' Prepare e-mail with PDF attachment
    With OutlApp.CreateItem(0)
    ' Define PDF filename
    For Each Sh In Worksheets
        If Left(Sh.Name, 4) = "DATA" Then
            PdfFile = ActiveWorkbook.FullName
            i = InStrRev(PdfFile, ".")
            If i > 1 Then PdfFile = Left(PdfFile, i - 1)
            PdfFile = PdfFile & "_" & Sh.Name & ".pdf"
            ' Export activesheet as PDF
            With Sh
                .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            End With
            .Attachments.Add PdfFile
        End If
    Next Sh
    ' Prepare e-mail
    .Subject = Title
    .To = Range("H13") ' <-- Put email of the recipient here
    .CC = Range("H17") ' <-- Put email of 'copy to' recipient here
    .Body = Range("h23")
    ' Try to send
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
        MsgBox "E-mail was not sent", vbExclamation
    Else
        MsgBox "E-mail successfully sent", vbInformation
    End If
    On Error GoTo 0
    End With
    ' Delete PDF file
    Kill PdfFile
    ' Quit Outlook if it was created by this code
    If IsCreated Then OutlApp.Quit
    ' Release the memory of object variable
    Set OutlApp = Nothing
End Sub

Believing · 9 Nisan 2021

Sayın NextLevel,

Konuya gösterdiğiniz ilgi için size teşekkür ederim.
Konu ile bir haftadır belli aralıklar ile çalışıyorum ve henüz müsbet bir sonuç alamadım.
Sizin konları denedim, Excel çalışma kitabını e-mail olarak göndermekte, gitmesi gerek PDF dosyasını masaüstüne kaydediyor ve gövde metnini eklememektedir.
Senaryolar 1 nolu mesaj gibi olup, çözüme ulaştırmanız çok makbule geçecektir.

Saygılarımla.

ÖmerFaruk · 9 Nisan 2021

Ben bu kodlarla kendime mail attım. 3 adet dosyayı da ekledi

Believing · 9 Nisan 2021

Sayın NextLevel

Elleriniz sağlık çok güzel olmuş ve son bir düzeltme gereklidir.
Bu çalışmaya yeni eklenecek sayfalar e-mail olarak göndirilecek ve ayrı ayrı sayfalar yerine birleştirilmiş PDF olarak olmalıdır.
Mevcut bütün sayfalar gönderimeyecek sayfalar olarak belirlenmelidir.

Saygılarımla.

ÖmerFaruk · 9 Nisan 2021

https://www.excel.web.tr/threads/exceldeki-tuem-calisma-sayfalarini-pdf-olarak-kaydetme.178397/
bu linkten faydalanabilirsiniz.

Believing · 9 Nisan 2021

Sayın NextLevel,

Örneklerden bir sonuç alamadım. Konuyu çözüme ulaştırırsanız çok makbule geçecektir.
İyi akşamlar

Saygılarımla.

Korhan Ayhan · 9 Nisan 2021

Deneyiniz.

Kaydedilen PDF dosyası mail gönderildikten sonra silinmektedir. Eğer silinmesini istemiyorsanız aşağıdaki satırı kaldırabilirsiniz.

Kill Yol & "\" & Dosya_Adi

C++:

Option Explicit

Sub PDF_KAYDET_MAIL_GONDER()
    Dim Yol As String, Dosya_Adi As String, Dosya_Uzantisi As String
    Dim Uygulama As Object, Yeni_Mail As Object, Veri As Range, Say As Byte
    Dim Sayfa As Worksheet, S1 As Worksheet, Onay As Byte, Mesaj As String, Adres As String
    
    On Error Resume Next
    Set Uygulama = GetObject(, "Outlook.Application")
    On Error GoTo 0
    
    If Uygulama Is Nothing Then Call Shell("Outlook.exe", vbHide)
    
    Set Uygulama = CreateObject("Outlook.Application")
    Set Yeni_Mail = Uygulama.CreateItem(0)

    Set S1 = Sheets("SETTINGS")
    
    Yol = ThisWorkbook.Path & Application.PathSeparator
    Dosya_Uzantisi = CreateObject("Scripting.FileSystemObject").GetExtensionName(ThisWorkbook.Name)
    Dosya_Adi = Replace(ThisWorkbook.Name, "." & Dosya_Uzantisi, "") & "-" & Format(S1.Range("H3").Value, "dd.mm.yyyy") & ".pdf"
    ChDir Yol
        
    Onay = MsgBox("Kayıt edip mail göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı")
    
    If Onay = vbYes Then
        ReDim Sayfalar(1 To 1)
    
        For Each Sayfa In ThisWorkbook.Sheets
            Select Case Sayfa.Name
                Case "LICENSE", "TEMPLATE", "PARAMETRE", "SETTINGS"
                Case Else
                    Say = Say + 1
                    ReDim Preserve Sayfalar(1 To Say)
                    Sayfalar(Say) = Sayfa.Name
            End Select
        Next
        
        On Error GoTo 10
        AppActivate Dosya_Adi, True
        SendKeys "%{F4}", True
        Application.Wait Now + TimeSerial(0, 0, 2)
    
10      Sheets(Sayfalar).Select
        
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=Yol & Dosya_Adi, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        
        S1.Select
        
        Mesaj = S1.Range("H23").Value & "<br><br>" & S1.Range("H25").Value & "<br><br>" & S1.Range("H31").Value
        
        Mesaj = "<p style='color:black;font-family:Calibri (Gövde);font-size:14.5'>" & Mesaj & "</font></p>"
        
        With Yeni_Mail
            .Display
            .To = S1.Range("H13").Value
            .CC = S1.Range("H17").Value
            .BCC = ""
            .Subject = S1.Range("H20").Value
            .HTMLBody = Mesaj & .HTMLBody
            .Attachments.Add Yol & Dosya_Adi
            .BodyFormat = 2
            .Save
            '.Send
        End With
        
        Kill Yol & "\" & Dosya_Adi
        
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Else
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
    End If
    
    Set S1 = Nothing
    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing
End Sub

Believing · 10 Nisan 2021

Sayın Korhan bey,

Ellerinize ve emeğinize sağlık kusursuz çalışmaktadır. Her türlü övgüye laik bir çalışma olmuş.
Outlook'u açmaksızın arka planda çalışarak göndermesi mümkün müdür?

Saygılarımla.

Korhan Ayhan · 10 Nisan 2021

Kurumsal imzanız için görünmesi gerekiyor. En azından ben öyle biliyorum.

Believing · 20 Mayıs 2021

Merhaba Korhan bey,

Yukarıdaki PDF formatında istenilen sayfaları birleştirerek e-mail gönderme çalışmanız kusursuz olmuştur.
Gelişen yeni şartlara göre, Excel çalışma kitabını mail olarak gönderme ihtiyacı doğmuştur.
Excel çalışma kitabının tamamını e-posta olarak gönderilirken, "LICENSE", "TEMPLATE", "PARAMETRE" isimli sayfaları gizlenecek.
"SETTINGS" isimli sayfadaki kayıtlı kişlere ve mail metnine göre göderilecek.
Bu koşullara göre e-mail gönderilmesini sağlamak için mevcut kodları nasıl revize etmeliyim?
Benim için çok değerli olan yardımlarınızı bir kez daha rica ederim.

Saygılarımla,

Korhan Ayhan · 20 Mayıs 2021

Deneyiniz.

C++:

Option Explicit

Sub EXCEL_KAYDET_MAIL_GONDER()
    Dim Yol As String, Dosya_Adi As String, Dosya_Uzantisi As String
    Dim Uygulama As Object, Yeni_Mail As Object, Veri As Range, Say As Byte
    Dim Sayfa As Worksheet, S1 As Worksheet, Onay As Byte, Mesaj As String, Adres As String
    
    On Error Resume Next
    Set Uygulama = GetObject(, "Outlook.Application")
    On Error GoTo 0
    
    If Uygulama Is Nothing Then Call Shell("Outlook.exe", vbHide)
    
    Set Uygulama = CreateObject("Outlook.Application")
    Set Yeni_Mail = Uygulama.CreateItem(0)

    Set S1 = Sheets("SETTINGS")
    
    Yol = ThisWorkbook.Path & Application.PathSeparator
    Dosya_Uzantisi = CreateObject("Scripting.FileSystemObject").GetExtensionName(ThisWorkbook.Name)
    Dosya_Adi = Replace(ThisWorkbook.Name, "." & Dosya_Uzantisi, "") & "-" & Format(S1.Range("H3").Value, "dd.mm.yyyy") & ".xlsx"
    ChDir Yol
        
    Onay = MsgBox("Kayıt edip mail göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı")
    
    If Onay = vbYes Then
        ReDim Sayfalar(1 To 1)
    
        For Each Sayfa In ThisWorkbook.Sheets
            Select Case Sayfa.Name
                Case "LICENSE", "TEMPLATE", "PARAMETRE", "SETTINGS"
                Case Else
                    Say = Say + 1
                    ReDim Preserve Sayfalar(1 To Say)
                    Sayfalar(Say) = Sayfa.Name
            End Select
        Next
        
        On Error GoTo 10
        AppActivate Dosya_Adi, True
        SendKeys "%{F4}", True
        Application.Wait Now + TimeSerial(0, 0, 2)
    
10      Sheets(Sayfalar).Copy
        
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=Yol & Dosya_Adi, FileFormat:=51
        Application.DisplayAlerts = True
        ActiveWorkbook.Close 0
        
        S1.Select
        
        Mesaj = S1.Range("H23").Value & "<br><br>" & S1.Range("H25").Value & "<br><br>" & S1.Range("H31").Value
        
        Mesaj = "<p style='color:black;font-family:Calibri (Gövde);font-size:14.5'>" & Mesaj & "</font></p>"
        
        With Yeni_Mail
            .Display
            .To = S1.Range("H13").Value
            .CC = S1.Range("H17").Value
            .BCC = ""
            .Subject = S1.Range("H20").Value
            .HTMLBody = Mesaj & .HTMLBody
            .Attachments.Add Yol & Dosya_Adi
            .BodyFormat = 2
            .Save
            '.Send
        End With
        
        Kill Yol & "\" & Dosya_Adi
        
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Else
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
    End If
    
    Set S1 = Nothing
    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing
End Sub

Believing · 21 Mayıs 2021

Merhaba Korhan bey,

Ellerinize ve emeğinize sağlık.
Affınıza sığınarak, çok özür dileyerek son bir isteğim daha olacaktır.
PDF için hazırladığınız 8. sayfadaki kodlar ile sayfaları birleştirerek e-mail gönderiyorduk. Sayfaları ayırmak için 8. sayfadaki kodları nasıl revize etmeliyiz.
Eğer bunu da sağlarsak konu ile ilgi başka sorum olmayacağını ümit ediyorum.

Saygılarımla,

Korhan Ayhan · 21 Mayıs 2021

3 sayfayı 3 ayrı pdf dosyası yaparak mı maile eklemek istiyorsunuz?

Believing · 21 Mayıs 2021

Örnekteki çalışmada 3 sayfayı ayrı ayrı e-mail'e eklemek istiyorum.
Asıl çalışmada 7 sayfa olmaktadır.

Korhan Ayhan · 21 Mayıs 2021

Peki dosya adları ne olacak?

Believing · 21 Mayıs 2021

Dosyalar isimlerini sayfa isimleri ile "H3" hücresindeki tarih ile birleştirilerek oluşmalıdır.
Örneğin; Sayfa ismi "DATA_RVZ" ise, yeni isim "DATA_RVZ - 20.05.2021" şeklinde olmalıdır.

Saygılarımla,

Korhan Ayhan · 21 Mayıs 2021

Deneyiniz.

C++:

Option Explicit

Sub SAYFALARI_AYRI_AYRI_PDF_KAYDET_MAIL_GONDER()
    Dim Yol As String, Dosya_Adi As String, Dosya As Variant, Adres As String
    Dim Uygulama As Object, Yeni_Mail As Object, Veri As Range, Say As Byte
    Dim Sayfa As Worksheet, S1 As Worksheet, Onay As Byte, Mesaj As String
    
    On Error Resume Next
    Set Uygulama = GetObject(, "Outlook.Application")
    On Error GoTo 0
    
    If Uygulama Is Nothing Then Call Shell("Outlook.exe", vbHide)
    
    Set Uygulama = CreateObject("Outlook.Application")
    Set Yeni_Mail = Uygulama.CreateItem(0)

    Set S1 = Sheets("SETTINGS")
    
    Yol = ThisWorkbook.Path & Application.PathSeparator
    ChDir Yol
        
    Onay = MsgBox("Kayıt edip mail göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı")
    
    If Onay = vbYes Then
        On Error GoTo 10
        AppActivate Dosya_Adi, True
        SendKeys "%{F4}", True
        Application.Wait Now + TimeSerial(0, 0, 2)
    
10      ReDim Dosyalar(1 To 1)
        
        For Each Sayfa In ThisWorkbook.Sheets
            Select Case Sayfa.Name
                Case "LICENSE", "TEMPLATE", "PARAMETRE", "SETTINGS"
                Case Else
                    Dosya_Adi = Sayfa.Name & "-" & Format(S1.Range("H3").Value, "dd.mm.yyyy") & ".pdf"
                    Sayfa.ExportAsFixedFormat Type:=xlTypePDF, _
                    Filename:=Yol & Dosya_Adi, Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
                    Say = Say + 1
                    ReDim Preserve Dosyalar(1 To Say)
                    Dosyalar(Say) = Yol & Dosya_Adi
            End Select
        Next
        
        S1.Select
        
        Mesaj = S1.Range("H23").Value & "<br><br>" & S1.Range("H25").Value & "<br><br>" & S1.Range("H31").Value
        
        Mesaj = "<p style='color:black;font-family:Calibri (Gövde);font-size:14.5'>" & Mesaj & "</font></p>"
        
        With Yeni_Mail
            .Display
            .To = S1.Range("H13").Value
            .CC = S1.Range("H17").Value
            .BCC = ""
            .Subject = S1.Range("H20").Value
            .HTMLBody = Mesaj & .HTMLBody
             For Each Dosya In Dosyalar
                .Attachments.Add Dosya
             Next
            .BodyFormat = 2
            .Save
            '.Send
        End With
        
        For Each Dosya In Dosyalar
            Kill Dosya
        Next
        
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Else
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
    End If
    
    Set S1 = Nothing
    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing
End Sub

Believing · 21 Mayıs 2021

Sayın Korhan bey,

Size ne kadar övgü ve methiyeler göndersem azdır. Muhteşem olmuş. Ellerinize ve emeğinize sağlık.
ALLAH sizden ve sevdiklerinizden razı olsun.
Hakkınızı helal ediniz lütfen.
Cuma gününüz hayırlara vesile olur inşallah.
Kolay gelsin.

Saygılarımla,

Korhan Ayhan · 21 Mayıs 2021

Amin.. Hakkım varsa helal olsun..

Excel ile Outlook'u kullanarak e-mail gönderme

Believing

E-Mail_Gonder.rar dosyasını indir - download

Ekli dosyalar

ÖmerFaruk

Destek Ekibi

Believing

ÖmerFaruk

Destek Ekibi

Believing

ÖmerFaruk

Destek Ekibi

Believing

Korhan Ayhan

Administrator

Believing

Korhan Ayhan

Administrator

Believing

Korhan Ayhan

Administrator

Believing

Korhan Ayhan

Administrator

Believing

Korhan Ayhan

Administrator

Believing

Korhan Ayhan

Administrator

Believing

Korhan Ayhan

Administrator