Toplu Mail ve Ek Gönderme

[kucukdunyam]

Excel Tablomun içerisindeki verilere göre, istenilen adreslere istenilen klasörün içindeki ekleri gönderebilir miyiz.

 

[Huseyinkis]

Merhaba ekteki kodları inceler misiniz.

Sub mailgon()
Dim strDate As String
Dim OutApp As Outlook.Application
Dim NewMail As Outlook.MailItem
        
For x1 = 6 To Cells(Rows.Count, 3).End(3).Row
        
Set OutApp = New Outlook.Application
Set NewMail = CreateItem(olMailItem)
With NewMail
On Error Resume Next

.To = Cells(x1, 3).Value
.Subject = Cells(x1, 2).Value
.Body = Cells(x1, 4).Value

dosya = Split(Cells(x1, 5).Value, ", ")

For X2 = 0 To UBound(dosya)
.Attachments.Add "C:\Users\Hakan\Desktop\Dağıtım\" & dosya(X2) & ".xls"
.Attachments.Add "C:\Users\Hakan\Desktop\Dağıtım\" & dosya(X2) & ".Doc"
Next X2

.Save
.Send
End With
Set NewMail = Nothing
Set OutApp = Nothing
Next x1
End Sub

[/CODE]

 

[kucukdunyam]

Yalnız Windows Live Mail kullanıyorum. Bu kodu Windows Live Mail'e göre nasıl uyarlayabiliriz.

 

[kucukdunyam]

Yardımcı Olabilecek Kimse Yok mu?


Windows mail için Bir kod buldum yalnız düzenlenmesi gerekiyor.
Sub yeni()
Dim wb As Workbook
Dim I As Long

Set wb = ActiveWorkbook

On Error Resume Next
For I = 1 To 3
wb.SendMail "uzlasma@bursavdb.gov.tr", _
"Bu bir örnek Dosyadır"
If Err.Number = 0 Then Exit For
Next I
On Error GoTo 0
End Sub

 

[kucukdunyam]

Birleştirmeye Çalıştığım Kadarıyla,

Sub yeni()
Dim wb As Workbook
Dim x1 As Long

For x1 = 6 To Cells(Rows.Count, 3).End(3).Row
On Error Resume Next
dosya = Split(Cells(x1, 5).Value, ", ")
For x1 = 0 To UBound(dosya)
.Attachments.Add "C:\Users\Hakan\Desktop\Dağıtım\" & dosya(x1) & ".xls"
.Attachments.Add "C:\Users\Hakan\Desktop\Dağıtım\" & dosya(x1) & ".Doc"
Next x1
x1.SendMail Cells(x1, 3).Value, _
Cells(x1, 2).Value, _
Cells(x1, 4).Value
If Err.Number = 0 Then Exit For
Next I
On Error GoTo 0
End Sub

 

[kucukdunyam]

Yardım Edebilirmisiniz?

 

[kucukdunyam]

Olmasını istediğim Son haliyle dosyayı yeniden ekledim. Gözat penceresinden seçeceğim klasörün içindeki dosyaları ilgili adreslere mail olarak göndermek istiyorum.

 

[kucukdunyam]

Kimse bu formlara bakmaz mı? Yeniden konu mu açmam gerekiyor.

 

[antonio]

Yalnız Windows Live Mail kullanıyorum. Bu kodu Windows Live Mail'e göre nasıl uyarlayabiliriz.

Windows Live mail iletilerinizi outlook tan alacak şekilde pop3 ile yönlendirin. Böylelikle mevcut kodları sorunsuzca kullanabilirsiniz.

 

[kucukdunyam]

Bu söylediğiniz şeyi nasıl yapacağım, yardımcı olabilirmisiniz? windows 7 kullanıyorum. Varsayılan e posta yöneticisi Windows Live Mail

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu deneyiniz.

Bu yöntemi ilk defa denedim. Bende varsayılan mail sistemi "outlook" ayarlı olduğu için mail gönderilirken güvenlik uyarısı ile karşılaştım.

Ayrıca bu yöntemde ilgili dosyaları tek tek mail adreslerine yollamayı başarabildim. Birden fazla mail adresine birden fazla dosyayı aynı anda göndermeyi başaramadım. Belki de bu yöntemde işlem bu şekilde olmuyordur. Dediğim gibi ilk defa denedim. Konuya hakim diğer üyelerimiz belki kodu geliştirebilir.

Sub Mail_Gonder()
    Dim K1 As Workbook, K2 As Workbook, S1 As Worksheet
    Dim Klasor As Object, Yol As String
    Dim X As Long, Y As Byte, Z As Byte
    Dim Dosya As Variant, Adres As Variant

    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("mail listesi")
    
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Klasör Seçiniz...", 1)
    If Klasor Is Nothing Then Exit Sub
    Yol = Klasor.Items.Item.Path
    
    On Error Resume Next
    
    For X = 6 To S1.Cells(Rows.Count, 2).End(3).Row
        Dosya = Split(Trim(S1.Cells(X, 5)), ",")
        For Y = 0 To UBound(Dosya)
            If Dir(Yol & "\" & Trim(Dosya(Y))) <> "" Then
                Set K2 = Workbooks.Open(Yol & "\" & Trim(Dosya(Y)))
                Adres = Split(Trim(S1.Cells(X, 3)), ",")
                For Z = 0 To UBound(Adres)
                    K2.SendMail Trim(Adres(Z)), S1.Cells(X, 2)
                Next
                K2.Close False
            End If
        Next
        If Err.Number = 0 Then Exit For
    Next
    
    On Error GoTo 0
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[kucukdunyam]

Korhan Bey
Dosya = Split(Trim(S1.Cells(X, 5)), ",")
Satırında Trim Komutunda hata alıyorum, Karşılaştığım hata: Cant find object or librariy,

Sanırım 64 bit kullanmam ile ilgiliymiş, sorunu çözdüm

 

[antonio]

Bu söylediğiniz şeyi nasıl yapacağım, yardımcı olabilirmisiniz? windows 7 kullanıyorum. Varsayılan e posta yöneticisi Windows Live Mail

Ayarların nasıl yapılacağı aşağıda ki bağlantıda iyi anlatılmış.
http://shiftdelete.net/hotmail-pop3-ayarlari-9475.html

 

[kucukdunyam]

Evet Adres çubuğuna Birden fazla mail yazılınca göndermiyor,