Excel ile Eposta Gönderme Hk.

D

dnmtnk

Katılım
20 Şubat 2012
Mesajlar
114
Excel Vers. ve Dili
Excel 2013 TR
Arkadaşlar ekteki dosya ile bir klasör içerisindeki dosyaları mail gönderiyorum. Ancak bu eklenen dosyaların isimlerini kontrol etmem gerekiyor.

Örneğin;
27.09.2017 dosya.txt
27.09.2017 arsiv.txt
27.09.2017 resim.jpg
27.09.2017 excel.xlsx

bu ve buna benzer 4-5 dosya olacak klasörde.

Bu dosya isimlerini excelin herhangi bir yerinde koşullandırmak mümkün mü? İlk kısımda tarih devamında dosya adı devamında uzantısı olacak. Belirtilen hücredeki dosya adıyla uyuşmuyorsa "Dosya adı yanlış" şeklinde uyarı verecek. Nasıl yapabilirim yardımcı olursanız memnun olurum.

NOT: Konu başlığı, gönderilecek kişiler, konu içeriği excelin eposta sayfasından girilebilsin ayrıca html imza da olsun istiyorum.
 

Ekli dosyalar

Asri

Asri

Katılım
24 Nisan 2005
Mesajlar
3,671
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
En fazla 8 dosya ekleyebilir. Klasörde 8 den fazla dosya var ise ekleyemeyecektir.

Kontrol ediniz.

Kod: 
Sub mailgonder_eposta1()
      Call Guncelle_Rapor
      
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
      yol = ActiveWorkbook.Path & "\EPOSTA1\"
      With OutMail
       .To = [C2]
       .CC = ""
       .BCC = ""
       .Subject = [C3]
        If [C5] <> "" Then .Attachments.Add yol & [C5]
        If [C6] <> "" Then .Attachments.Add yol & [C6]
        If [C7] <> "" Then .Attachments.Add yol & [C7]
        If [C8] <> "" Then .Attachments.Add yol & [C8]
        If [C9] <> "" Then .Attachments.Add yol & [C9]
        If [C10] <> "" Then .Attachments.Add yol & [C10]
        If [C11] <> "" Then .Attachments.Add yol & [C11]
        If [C12] <> "" Then .Attachments.Add yol & [C12]
        
       .Display
       .HTMLBody = [C4] & .HTMLBody
       
       'Maili otomatik göndermek için .send deki tırnak işaretini kaldırın.
       '.send

       End With
      
      Set wrdEdit = Nothing
      Set OutMail = Nothing
      Set OutApp = Nothing
End Sub

Sub mailgonder_eposta2()
      Call Guncelle_Rapor

      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
      yol = ActiveWorkbook.Path & "\EPOSTA2\"
      With OutMail
       .To = [F2]
       .CC = ""
       .BCC = ""
       .Subject = [F3]
        If [F5] <> "" Then .Attachments.Add yol & [F5]
        If [F6] <> "" Then .Attachments.Add yol & [F6]
        If [F7] <> "" Then .Attachments.Add yol & [F7]
        If [F8] <> "" Then .Attachments.Add yol & [F8]
        If [F9] <> "" Then .Attachments.Add yol & [F9]
        If [F10] <> "" Then .Attachments.Add yol & [F10]
        If [F11] <> "" Then .Attachments.Add yol & [F11]
        If [F12] <> "" Then .Attachments.Add yol & [F12]
        
       .Display
       .HTMLBody = [F4] & .HTMLBody
       
       'Maili otomatik göndermek için .send deki tırnak işaretini kaldırın.
       '.send

       End With
      
      Set wrdEdit = Nothing
      Set OutMail = Nothing
      Set OutApp = Nothing
End Sub


Sub Guncelle_Rapor()
    Dim Dosya As String, Klasor As String, i As Integer, Deg
    
   Set shliste = Sheets("LISTE")
   sonsatir = shliste.Cells(Rows.Count, "A").End(3).Row
   kimerapor1 = ""
   kimerapor2 = ""
   For i = 1 To sonsatir
     grup = shliste.Cells(i, "F").Value
     mail = shliste.Cells(i, "E").Value
     If grup = "RAPOR1" Then
       kimerapor1 = kimerapor1 & mail & ";"
     End If
     If grup = "RAPOR2" Then
       kimerapor2 = kimerapor2 & mail & ";"
     End If
   Next i
   [C2] = kimerapor1
   [F2] = kimerapor2
   
'Dosya listesi güncelleniyor

    [C5:C12] = ""
    Klasor = ActiveWorkbook.Path & "\EPOSTA1\"
    Dosya = Dir(Klasor)
    Satir = 4
    While Dosya <> ""
        Satir = Satir + 1
        Cells(Satir, "C").Value = Dosya
        Dosya = Dir
        If Satir = 12 Then Dosya = ""
    Wend


    [F5:F12] = ""
    Klasor = ActiveWorkbook.Path & "\EPOSTA2\"
    Dosya = Dir(Klasor)
    Satir = 4
    While Dosya <> ""
        Satir = Satir + 1
        Cells(Satir, "F").Value = Dosya
        Dosya = Dir
        If Satir = 12 Then Dosya = ""
    Wend
    
End Sub
 

Ekli dosyalar

D

dnmtnk

Katılım
20 Şubat 2012
Mesajlar
114
Excel Vers. ve Dili
Excel 2013 TR
Sayın Asri Akdeniz, elinize emeğinize sağlık. Vermiş olduğunuz kodlar ve dosya harika oldu. Son bir ekleme daha yapabilmeniz mümkünse imza.html dosyasını da kodların içine entegre edebilir miyiz?

Sizin göndermiş olduğunuz dosyanın düzenlenmiş son halini ekte gönderiyorum. Yardımlarınız için teşekkür ederim.
 

Ekli dosyalar

Asri

Asri

Katılım
24 Nisan 2005
Mesajlar
3,671
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
dnmtnk' Alıntı:
Sayın Asri Akdeniz, elinize emeğinize sağlık. Vermiş olduğunuz kodlar ve dosya harika oldu. Son bir ekleme daha yapabilmeniz mümkünse imza.html dosyasını da kodların içine entegre edebilir miyiz?

Sizin göndermiş olduğunuz dosyanın düzenlenmiş son halini ekte gönderiyorum. Yardımlarınız için teşekkür ederim.
Genişletmek için tıkla ...
Kodlar sizin outlook daki imzanızı kullanır.
 
S

sekozzy

Katılım
30 Eylül 2016
Mesajlar
53
Excel Vers. ve Dili
Excel Standart 2016 x64 TR
Altın Üyelik Bitiş Tarihi
30/09/2017
Sayın Asri Akdeniz ve konu hakkında bilgisi olan diğer arkadaşlar,

#2 nolu mesajdaki kodları kendi bilgisayarımda kullandığımda sorunsuz çalışıyor fakat başka bilgisayarda kullandığımda

Kod: 
       .To = [F2]
       .CC = ""
       .BCC = ""
       .Subject = [F3]
F2 ve F3 yazan kısımlarda hata veriyor. Bunları Range("F2").value şeklinde değiştirince hata vermiyor. Farkı nedir?

Diğer bir sorun ise tüm ayarların diğer bilgisayarla aynı gözükmesine rağmen 2.bilgisayarda gönder butonuna bastıktan sonra sağ altta outlook simgesi çıkıyor sonra kapanıyor fakat mail iletilmiyor. Outlook programını manuel olarak açtığımda mailin Giden kutusunda beklediğini görüyorum. Outlook'u açtıktan en geç 1 dk sonra ise mail gönderilerek Gönderilmişler klasörüne geçiyor. Bunun nedeni hakkında bilgisi olan var mı acaba?

Edit: Mailde eklentilere ait kodları kaldırınca kodlar sorunsuz çalışıyor. Eklenti kodları varken dosya giden kutusunda takılıyor.

Kod: 
        If [C5] <> "" Then .Attachments.Add yol & [C5]
        If [C6] <> "" Then .Attachments.Add yol & [C6]
        If [C7] <> "" Then .Attachments.Add yol & [C7]
        If [C8] <> "" Then .Attachments.Add yol & [C8]
        If [C9] <> "" Then .Attachments.Add yol & [C9]
        If [C10] <> "" Then .Attachments.Add yol & [C10]
        If [C11] <> "" Then .Attachments.Add yol & [C11]
        If [C12] <> "" Then .Attachments.Add yol & [C12]
 
Son düzenleme:
Asri

Asri

Katılım
24 Nisan 2005
Mesajlar
3,671
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
Outlook / kurallar / gecikmeli teslimat gibi bir kural yazılmış olabilir.
 
S

sekozzy

Katılım
30 Eylül 2016
Mesajlar
53
Excel Vers. ve Dili
Excel Standart 2016 x64 TR
Altın Üyelik Bitiş Tarihi
30/09/2017
S

sekozzy

Katılım
30 Eylül 2016
Mesajlar
53
Excel Vers. ve Dili
Excel Standart 2016 x64 TR
Altın Üyelik Bitiş Tarihi
30/09/2017
Arkadaşlar flood gibi oluyor ama sorunum halem devam ediyor. Konu hakkında başka önerisi olan var mı?
 
S

sekozzy

Katılım
30 Eylül 2016
Mesajlar
53
Excel Vers. ve Dili
Excel Standart 2016 x64 TR
Altın Üyelik Bitiş Tarihi
30/09/2017
Sayın asri akdeniz,

kodları biraz revize ettim. Şimdi buna imza eklemek istiyorum. Yardımcı olursanız sevinirim.

Kod: 
Sub mailgonder_eposta1()
Call Guncelle_Rapor

Dim adres As String, Subject As String, HTMLBody As String, BCC As String
Dim iMsg As Object, iConf As Object, Flds
Application.DisplayAlerts = False

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
schema = "http://schemas.microsoft.com/cdo/configuration/"
Flds.Item(schema & "sendusing") = 2
Flds.Item(schema & "smtpserver") = "smtp.yandex.com.tr"
Flds.Item(schema & "smtpserverport") = 465
Flds.Item(schema & "smtpauthenticate") = 1
Flds.Item(schema & "sendusername") = "kullaniciadi@domain.com"
Flds.Item(schema & "sendpassword") = "sifre"
Flds.Item(schema & "smtpusessl") = 1
Flds.Update
yol = ActiveWorkbook.Path & "\EPOSTA1\"
    With iMsg
        .To = [C2]
        .CC = ""
        .BCC = ""
        .From = "Adınız <kullaniciadi@domain.com>"
        .Subject = [C3]
        .HTMLBody = [C4]
        If [C6] <> "" Then .AddAttachment yol & [C6]
        If [C7] <> "" Then .AddAttachment yol & [C7]
        If [C8] <> "" Then .AddAttachment yol & [C8]
        If [C9] <> "" Then .AddAttachment yol & [C9]
        If [C10] <> "" Then .AddAttachment yol & [C10]
        If [C11] <> "" Then .AddAttachment yol & [C11]
        If [C12] <> "" Then .AddAttachment yol & [C12]
        If [C13] <> "" Then .AddAttachment yol & [C13]
        .Sender = "Gonderen"
        .Organization = "Firma"
        .ReplyTo = "kullaniciadi@domain.com"
    Set .Configuration = iConf
        SendEmail = .Send
        syol = vbNullString
        mailadresi = vbNullString
        adres = vbNullString
        Application.DisplayAlerts = True
        MsgBox "E-posta ve dosya gönderildi.   ", vbInformation, "www.domain.com"
    End With
Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing

End Sub
 
S

sekozzy

Katılım
30 Eylül 2016
Mesajlar
53
Excel Vers. ve Dili
Excel Standart 2016 x64 TR
Altın Üyelik Bitiş Tarihi
30/09/2017
Asri Akdeniz'in Dikkatine

Konu güncel.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst