Excel Outlook İle Dosya Ekli Toplu Mail Gönderme - Oğuz Türkyılmaz - 09/04/2021
Merhaba
Bu kodları internette konuyla alakalı araştırma yaparken buldum fakat uygulama dosyası rar ile açıldığında hasarlı olduğundan kodlarla işleyiş arasında bağlantı kuramadığımdan bu kodları kendi projeme adapte edemedim.
Bu kodları WINPERAX Excel çalışma sayfamın Ana_Sayfa sekmesinde bulunan Mail gönder butonuna basarak masa üstümde yer alan bir PDF dosyasını mail adreslerinin tümüne eklemek ve topluca mail göndermek için nasıl revize etmeliyim. Çok fazla mail adresi olduğunda gönderim esnasında ID numarasına göre başlangıç ve bitiş numaraları vererek sınırlama getirilmiş ve sorun oluşturabilecek bu durum kodda zaten çözülmüş. Ben bu kodları uygulamama nasıl adapte edebilirim. Yardımlarınız için şimdiden teşekkür ederim. Parola : 171717
Sub kod_PDF_mail()
Klasor = Range("m36")
On Error Resume Next
If Dir(Klasor) = "" Then MkDir Klasor
Dim yol_isim As String
Dim kayıt_yeri As String
Dim i As Long
kayıt_yeri = Range("M36")
basla = InputBox("Başlangınç No")
If basla = "" Then Exit Sub
bitis = InputBox("Bitiş No")
If bitis = "" Then Exit Sub
If CreateObject("scripting.filesystemobject").folderexists(kayıt_yeri) = False Then _
CreateObject("scripting.filesystemobject").createfolder (kayıt_yeri)
For i = basla To bitis
Range("N11") = i
If Range("N14") <> "" Then
yol_isim = Range("M37")
Sheets("MUTABAKAT FORMU").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=yol_isim, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
With Application
.EnableEvents = True
End With
Dim objOutlook As Object
Dim objMail As Object
Dim NoA As Long
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = Range("N21")
.cC = Range("N20")
.Subject = Range("M35")
.body = "Sayın yetkili, Ekte tarafınıza ait mutabakat mektubu bulunmaktadır. En kısa sürede geri dönüşünüzü bekliyoruz. Saygılarımızla,"
.Attachments.Add yol_isim
.Importance = 2
.Save
.Display
'.Send ' gönder
Sheets("Aktif Bayiler").Cells(i + 6, "R") = "Mail gönderildi"
End With
End If
Next i
Set objMail = Nothing
Set objOutlook = Nothing
End Sub
RE: Excel Outlook İle Dosya Ekli Toplu Mail Gönderme - kanakan52 - 09/04/2021
(09/04/2021, 01:17)Oğuz Türkyılmaz yazdı: Merhaba
Bu kodları internette konuyla alakalı araştırma yaparken buldum fakat uygulama dosyası rar ile açıldığında hasarlı olduğundan kodlarla işleyiş arasında bağlantı kuramadığımdan bu kodları kendi projeme adapte edemedim.
Bu kodları WINPERAX Excel çalışma sayfamın Ana_Sayfa sekmesinde bulunan Mail gönder butonuna basarak masa üstümde yer alan bir PDF dosyasını mail adreslerinin tümüne eklemek ve topluca mail göndermek için nasıl revize etmeliyim. Çok fazla mail adresi olduğunda gönderim esnasında ID numarasına göre başlangıç ve bitiş numaraları vererek sınırlama getirilmiş ve sorun oluşturabilecek bu durum kodda zaten çözülmüş. Ben bu kodları uygulamama nasıl adapte edebilirim. Yardımlarınız için şimdiden teşekkür ederim. Parola : 171717
Sub kod_PDF_mail()
Klasor = Range("m36")
On Error Resume Next
If Dir(Klasor) = "" Then MkDir Klasor
Dim yol_isim As String
Dim kayıt_yeri As String
Dim i As Long
kayıt_yeri = Range("M36")
basla = InputBox("Başlangınç No")
If basla = "" Then Exit Sub
bitis = InputBox("Bitiş No")
If bitis = "" Then Exit Sub
If CreateObject("scripting.filesystemobject").folderexists(kayıt_yeri) = False Then _
CreateObject("scripting.filesystemobject").createfolder (kayıt_yeri)
For i = basla To bitis
Range("N11") = i
If Range("N14") <> "" Then
yol_isim = Range("M37")
Sheets("MUTABAKAT FORMU").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=yol_isim, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
With Application
.EnableEvents = True
End With
Dim objOutlook As Object
Dim objMail As Object
Dim NoA As Long
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = Range("N21")
.cC = Range("N20")
.Subject = Range("M35")
.body = "Sayın yetkili, Ekte tarafınıza ait mutabakat mektubu bulunmaktadır. En kısa sürede geri dönüşünüzü bekliyoruz. Saygılarımızla,"
.Attachments.Add yol_isim
.Importance = 2
.Save
.Display
'.Send ' gönder
Sheets("Aktif Bayiler").Cells(i + 6, "R") = "Mail gönderildi"
End With
End If
Next i
Set objMail = Nothing
Set objOutlook = Nothing
End Sub
Merhaba,
Kontrol eder misiniz ?
RE: Excel Outlook İle Dosya Ekli Toplu Mail Gönderme - Oğuz Türkyılmaz - 09/04/2021
Sn.Kanakan52 dosyada ne gibi bir işlem yaptığınızı anlayamadım sadece mail gönder butonuna tıkladığınızda dosya seçme dialog kutusu çıkıyor doya ekle dediğinizde de herhangi bir işlem gerçekleşmiyor diye yazmıştım ki butonun olayına bakmak geldi aklıma şimdi orayı inceleyip dönüş yapacağım. Teşekkür ederim.
RE: Excel Outlook İle Dosya Ekli Toplu Mail Gönderme - Oğuz Türkyılmaz - 09/04/2021
Sn.Kanakan52 İşlem gerçekleştiğinde otomatik olarak outlooku açmıyor ben manuel olarak outlooku açtığımda mail işleminin gideceği hesapları vs hepsini Taslaklarda görüyorum fakat ekle diyerek dialog kutusundan seçtiğim dosya eklenmiş olarak gözükmüyor. İkinci defa mail göndermek istediğimde ise işlem hiç gerçekleşmiyor.
Private Sub CommandButton2_Click()
On Error Resume Next
Dim son As Integer
son = Range("F65536").End(3).Row
dosya = Application.GetOpenFilename("Files (*.**)," & "*.**", 1, "Select File", "Open", False)
For i = 2 To Sayfa1.Range("a65536").End(3).Row
Mail = Mail + ";" + Sayfa1.Cells(i, 4).Value
Next i
Dim OutlookApp As Object, OutlookMsg As Object
Dim FSO As Object
Dim MySignature As Object
Set FSO = CreateObject("Scripting.FilesystemObject")
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMsg = OutlookApp.CreateItem(0)
With OutlookMsg
.To = Mail
.cC = "buraya cc yazılacak"
.Subject = Sayfa1.Cells(i, 3).Value
.body = "mesajı buraya yazın"
.Attachments.Add dosya
.Importance = 2
.Save
.Display
.Send ' en baştaki tek tırnağı kaldırırsanız doğrudan gönderir
End With
Set MySignature = Nothing
Set OutlookMsg = Nothing
Set OutlookApp = Nothing
Set FSO = Nothing
End Sub
Re: Excel Outlook İle Dosya Ekli Toplu Mail Gönderme - Oğuz Türkyılmaz - 09/04/2021
Kodları aşağıdaki gibi revize ettim şu an PDF formatında dosyaları dialog kutusundan seçip ekleyerek gönderebiliyorum fakat Excel ve word dosyalarını eklemek mümkün olmuyor. Sorunun nedeni konusunda bilgilendirirseniz çok makbule geçecek. Son olarak öğrenmek istediğim bu dosyada 3 ila 4 bin arası mail adresi olacak. For döngüsü ile tüm mail adreslerini bu şekilde eklemek outlook da sorun olur diye okudum ve her satırdaki ID ye göre başlangıç ve bitiş numarası vererek bir seferde sorunsuz kaç mail gönderebileceğim konusu nasıl çözülebilir fikriniz varsa öğrenmek isterim. Çok teşekkürler.
Private Sub CommandButton2_Click()
On Error Resume Next
Dim son As Integer
son = Range("F65536").End(3).Row
ek = Application.GetOpenFilename("Files (*.**)," & "*.**", 1, "Select File", "Open", False)
For i = 2 To Sayfa1.Range("a65536").End(3).Row
Mail = Mail + ";" + Sayfa1.Cells(i, 7).Value
Next i
Dim OutlookApp As Object, OutlookMsg As Object
Dim FSO As Object
Dim MySignature As Object
Set FSO = CreateObject("Scripting.FilesystemObject")
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMsg = OutlookApp.CreateItem(0)
With OutlookMsg
.To = Mail
.cC = "buraya cc yazılacak"
.Subject = Sayfa1.Cells(i, 3).Value
.body = "mesajı buraya yazın"
.Attachments.Add ek
.Importance = 2
.Save
.Display
.Send
End With
Set MySignature = Nothing
Set OutlookMsg = Nothing
Set OutlookApp = Nothing
Set FSO = Nothing
End Sub
RE: Excel Outlook İle Dosya Ekli Toplu Mail Gönderme - feraz - 09/04/2021
Alttaki gibi deneyiniz.Yalnız .cC = "cc yaz" bu satır olursa hata veriyor.
Private Sub CommandButton2_Click()
Dim objOutlook As Object
Dim objMail As Object
Dim maill As String
Dim i As Long, dosya
Dim syfAna As Worksheet
Set syfAna = ThisWorkbook.Sheets("Ana_Sayfa")
dosya = Application.GetOpenFilename("Files (*.**)," & "*.**", 1, "Select File", "Open", False)
If dosya = vbNullString Then Exit Sub
If dosya = False Then Exit Sub
basla = InputBox("Baþlangýnç No")
If basla = "" Then Exit Sub
bitis = InputBox("Bitiþ No")
If bitis = "" Then Exit Sub
If WorksheetFunction.CountA(syfAna.Range("D2" & Rows.Count)) = 0 Then GoTo son
For i = basla To bitis
maill = maill & syfAna.Range("D" & i) & ";"
Next
maill = Left(maill, Len(maill) - 1)
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = maill
.cC = "cc yaz"
.Subject = "Konu yaz"
.body = "Sayýn yetkili, Ekte tarafýnýza ait mutabakat mektubu bulunmaktadýr. En kýsa sürede geri dönüþünüzü bekliyoruz. Saygýlarýmýzla,"
.Attachments.Add dosya
.Importance = 2
.Save
.Display
'.Send ' gönder
End With
MsgBox "Gönderildi..", vbInformation, "Bilgi"
var:
Set objMail = Nothing
Set objOutlook = Nothing
Set syfAna = Nothing
Exit Sub
son:
MsgBox "Hata oldu", vbCritical, "Hata"
GoTo var
End Sub
|