Çözüldü Liste ile Farklı Ek ve Farklı Adreslere Mail Gönderme

[RBozkurt]

A sütunundaki veriler METİN formatında girildi;
EKLER klasöründeki ek dosyalar A sütunundaki veri ile aynı ismi taşıması gerekir.

Makro çalışınca kaç adet mail varsa ekrana o kadar gönderme penceresi açılır...
Mağaza Numarası ile eşleşen ek yoksa o adrese mail göndermez.
*Listede 100 mail var, ek 25 ise > 25 mail gönderilir..

Örnekler ektedir.

**Microsoft Outlook olması ve hesap tanımlı olması gerekir.. Çalıştırmadan önce outlook programı açık olsun.

Sub Mail_At()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim lastRow As Long
    Dim magazaNum As String
    Dim magazaMail As String
    Dim ccMail As String
    Dim path As String
    Dim file As String
    Dim filePath As String
 
    ' Mağaza bilgileri bulunan sayfayı belirleme
    Set sh = ThisWorkbook.Sheets("Mail")
 
    ' Mağaza bilgileri bulunan son satırı bulma
    lastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
 
    ' Outlook uygulamasını başlatma
    Set OutApp = CreateObject("Outlook.Application")
 
    ' Mağaza bilgilerini kontrol etme
    For i = 2 To lastRow ' İlk satır başlık olduğu varsayılmıştır
        magazaNum = sh.Range("A" & i).Value
        magazaMail = sh.Range("B" & i).Value
        ccMail = sh.Range("C" & i).Value
     
        ' Dosya yolu ve ismini oluşturma
        path = ThisWorkbook.path & "\EKLER\"
        file = magazaNum & ".xlsx"
        filePath = path & file
     
        ' Dosyanın var olup olmadığını kontrol etme
        If Dir(filePath) <> "" Then
            ' Yeni e-posta oluşturma
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = magazaMail
                .CC = ccMail
                .Subject = magazaNum & " Mağaza Envanter Sonucu"
                .Body = magazaNum & " mağazasına ait envanter sonucu ektedir."
                .Attachments.Add (filePath)
                .Display ' Göndermeden önce maili kontrol etmek için
                '.Send ' Göndermek için
            End With
            Set OutMail = Nothing
        End If
    Next i
 
    Set sh = Nothing
    Set OutApp = Nothing
End Sub

Mail_Gonderme.rar dosyasını indir - download

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

s2.dosya.tc

 

[RBozkurt]

Maili otomatik gönderir. Güven ayarının yapılması gerekir.
.Display pasif / .Send aktif edilmiştir.

Sub Mail_At()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim lastRow As Long
    Dim magazaNum As String
    Dim magazaMail As String
    Dim ccMail As String
    Dim path As String
    Dim file As String
    Dim filePath As String
   
    ' Mağaza bilgileri bulunan sayfayı belirleme
    Set sh = ThisWorkbook.Sheets("Mail")
   
    ' Mağaza bilgileri bulunan son satırı bulma
    lastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
   
    ' Outlook uygulamasını başlatma
    Set OutApp = CreateObject("Outlook.Application")
   
    ' Mağaza bilgilerini kontrol etme
    For i = 2 To lastRow ' İlk satır başlık olduğu varsayılmıştır
        magazaNum = sh.Range("A" & i).Value
        magazaMail = sh.Range("B" & i).Value
        ccMail = sh.Range("C" & i).Value
       
        ' Dosya yolu ve ismini oluşturma
        path = ThisWorkbook.path & "\EKLER\"
        file = magazaNum & ".xlsx"
        filePath = path & file
       
        ' Dosyanın var olup olmadığını kontrol etme
        If Dir(filePath) <> "" Then
            ' Yeni e-posta oluşturma
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = magazaMail
                .CC = ccMail
                .Subject = magazaNum & " Mağaza Envanter Sonucu"
                .Body = magazaNum & " mağazasına ait envanter sonucu ektedir."
                .Attachments.Add (filePath)
                '.Display ' Göndermeden önce maili kontrol etmek için
                .Send ' Göndermek için
            End With
            Set OutMail = Nothing
        End If
    Next i
   
    Set sh = Nothing
    Set OutApp = Nothing
End Sub

Otomatik_Mail_Gonderme.rar dosyasını indir - download

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

www.dosya.tc