BİRDEN FAZLA ADRESE MAIL ATMA

[kneehot]

Arkadaşlar çok soru sordum ama daha önce bir şekil indirdiğim bir tabloyu şimdi kullanmak istedim fakat bir sorunu var. Birden çok satırı mail göndermek istiyorum fakat sadece ilk satırdaki firmanın mail adresine dosyasını gönderiyor. 2. ya da 3. firma girdiğinizde gitmiyor. Makromu öyle yazılmış yoksa ben mi bir yerde hata yapıyorum anlamadım.

 

[kneehot]

Sorunu çözdüm kusura bakmayın kirlilik oldu

 

[kneehot]

Sub MAIL()
'MAİL GÖNDERİMİ BAŞLANGIÇ
'NOT: TOOLS-REFERENCES TIKLA
'MİCROSOFT OUTLOOK 12.0 İŞARETLİ OLMALI

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Dim S1 As Worksheet
Dim S2 As Worksheet
Set S1 = Sheets("MAİL")

For i = 3 To S1.[B65536].End(3).Row
If S1.Cells(i, "I") = "x" Then

Dim Fs As Object
Set Fs = CreateObject("Scripting.FileSystemObject")
If Fs.FileExists(S1.Cells(i, "L")) Then
ek = S1.Cells(i, "L")
S1.Cells(i, "M") = "Var"
Else
ek = ""
S1.Cells(i, "M") = "Yok"
End If

konu = S1.Range("AA1")

Dim xlOutlook As Object
Dim xlMail As Object
Set xlOutlook = CreateObject("Outlook.Application")
Set xlMail = xlOutlook.CreateItem(0)

With xlMail
.To = S1.Cells(i, "E") & ";" & S1.Cells(i, "F") & ";" & S1.Cells(i, "G")
.CC = S1.Cells(i, "H")
'.BCC = S1.Cells(i, "S") & ";" & S1.Cells(i, "T")
.Subject = konu
.Body = S1.Range("AA3") & Chr(10) & S1.Range("AA4") & Chr(10) & _
S1.Range("AA5") & Chr(10) & S1.Range("AA6") & Chr(10) & _
S1.Range("AA7") & Chr(10) & S1.Range("AA8") & Chr(10) & _
S1.Range("AA9") & Chr(10) & S1.Range("AA10") & Chr(10) & _
S1.Range("AA11") & Chr(10) & S1.Range("AA12") & Chr(10) & _
S1.Range("AA13") & Chr(10) & S1.Range("AA14") & Chr(10) & _
S1.Range("AA15")
If ek <> "" Then
.Attachments.Add ek
End If
.Importance = 2
.Save
'.Display ' Mail Görüntüle
.Send ' Gönder
End With
S1.Cells(i, "J") = Format(Now(), "dd.mm.yy hh:mm")
S1.Cells(i, "K") = "J"
Range("MAIL1[GÖNDERİLECEK E-POSTA]").Select
Selection.ClearContents
Call Ilk_Bos_Hucreyi_Bulur_B_B

End If
Next i

Set xlMail = Nothing
Set xlOutlook = Nothing

With Application
.EnableEvents = True
.ScreenUpdating = True
End With
MsgBox " B i t t i "
End Sub


Arkadaşlar merhaba. Yukarıdaki makro ile müşterilere faturalarını mail gönderiyorum fakat outlook ta gönderim yapan mail adresine tanımlı firma logosu telefonu adresi olan imzayı eklemiyor. Başka bir makroda aşağıya eklediğim bir kod buldum ama nasıl eklenir bilemedim. Yardımcı olursanız çok sevinirim. Tüm yardımlara teşekkürler.

Set FSO = CreateObject("Scripting.FileSystemObject")
yol = "C:\Users\Ahmet\AppData\Roaming\Microsoft\Signatures\imza.htm"
Set imza = FSO.OpenTextFile(yol, 1)