merhaba,
excell üzerinden email göndermek istiyorum macro aşşağıda verdiğim gibi
ancak bu makroyu 8 saniyede bir mail gönderecek şekilde ayarlayabilirmiyiz acaba?
Maro:
---------------------------
Sub gonder()
Application.ScreenUpdating = False
On Error Resume Next
Dim ek As Object
Dim objOlk As Object, evn As Object, strresmim
Dim objEkle As Object, objevn As Object, evngovde As String
Rem Www.ExcelVBA.Net - 29.06.2010 - Tarkan VURAL
Dim firma
'aa = [b65536].End(3).Row
aa = InputBox("Satır sayısı giriniz:")
If aa = "" Then
Exit Sub
End If
For h = 2 To aa
firma = Range("b" & h)
strresmim = Range("h" & h) & ".jpg"
'ActiveWindow.DisplayGridlines = False
'Range("a1:c9").CopyPicture xlScreen, xlBitmap
'ActiveWindow.DisplayGridlines = True
'ActiveSheet.ChartObjects.Add 0, 0, 200, 100
'Set ek = ActiveSheet.ChartObjects(1).Chart
' ek.Paste
' ek.Export strresmim
' ek.Parent.Delete
Set objOlk = CreateObject("Outlook.Application")
Set evn = objOlk.CreateItem(0)
evn.To = Range("f" & h)
'evn.CC = [h2].Value
'evn.BCC = [h3].Value
evn.Subject = Range("g" & h)
evngovde = "<br></br>" & "<a></a>" & _
Range("c" & h) & " " & "Yeni Yılda Yine <b> Kurumsal Market </b>" & _
"<br><br>*******Yeni Yılda Kartuş Toner ve Şerit İhtiyaçlarınız İçin Size Yepyeni Bir Fırsat" & _
"<br>*******En Ucuz Fiyatlarla Tekrar Karşınızdayız" & _
"<br>*******Kargo <b>SADECE 1,00 TL</b>" & _
"<br></br>" & _
"<br>*******Satın aldığınız her ürün adınıza faturalı olarak kapınıza gelir ve beğeninize sunulur.<br>" & _
"<br> <br>" & _
"<br><b>En Güvenli Ödeme Şekilleri :</b><br>" & _
"******-*Kapıda Ödeme<br>" & _
"******-*Kredi Kartı İle Ödeme<br>" & _
"******-*Hesaba Havale<br>"
' "<br><br><b>Üyelik Bilgileriniz :</b><br>" & _
"********Kullanıcı Mailiniz*:" & " " & Range("d" & h) & _
"<br>********Şifreniz****************:" & " " & Range("e" & h) & "<br><br>"
Set objEkle = evn.Attachments
Set objevn = objEkle.Add(strresmim)
evn.Close olSave
evn.HTMLBody = evngovde & "<br><IMG alt='' hspace=0 src='cid:'" & _
strresmim & "'' align=baseline border=0><br></BODY>"
evn.HTMLBody = evngovde & "<br><IMG alt='' hspace=0 src='cid:'" & _
strresmim & "'' align=baseline border=0><br></BODY>" & _
"<br><br>Erman USTA<br>" & _
"<b>Satış Temsilcisi</b><br>" & _
"0532 341 12 19<br><br>" & _
"<b>Online Sipariş için: www.KURUMSALmarket.com</b><br>" & _
"<br> <br>" & _
Range("c" & h) & " " & "*******Müşterilerimiz için ve verdileri referanslar doğrultusunda hazırladığımız bu mail, sizin daha iyi şartlar altında çalışmanızı sağlamak amacı ile gönderilmiştir. Eğer size yardımcı olmamızı istemiyorsanız bu mesaja 'istemiyorum' yazarak cevap verebilirsiniz.<br>"
evn.Save
'evn.Display
evn.send
strresmim = vbNullString
Set evn = Nothing: Set objOlk = Nothing
Set objevn = Nothing: Set objEkle = Nothing
evngovde = vbNullString: Set ek = Nothing
Next h
Application.ScreenUpdating = True
End Sub
----------------
birde bu makroyu çalıştırırken gönderim için satır sayısı istiyor bununda kalkması gerek sanırım.
ekte örnek dosyayı ekledim ilgilenen arkadaşlara duyurulur. teşekkür ederim.
excell üzerinden email göndermek istiyorum macro aşşağıda verdiğim gibi
ancak bu makroyu 8 saniyede bir mail gönderecek şekilde ayarlayabilirmiyiz acaba?
Maro:
---------------------------
Sub gonder()
Application.ScreenUpdating = False
On Error Resume Next
Dim ek As Object
Dim objOlk As Object, evn As Object, strresmim
Dim objEkle As Object, objevn As Object, evngovde As String
Rem Www.ExcelVBA.Net - 29.06.2010 - Tarkan VURAL
Dim firma
'aa = [b65536].End(3).Row
aa = InputBox("Satır sayısı giriniz:")
If aa = "" Then
Exit Sub
End If
For h = 2 To aa
firma = Range("b" & h)
strresmim = Range("h" & h) & ".jpg"
'ActiveWindow.DisplayGridlines = False
'Range("a1:c9").CopyPicture xlScreen, xlBitmap
'ActiveWindow.DisplayGridlines = True
'ActiveSheet.ChartObjects.Add 0, 0, 200, 100
'Set ek = ActiveSheet.ChartObjects(1).Chart
' ek.Paste
' ek.Export strresmim
' ek.Parent.Delete
Set objOlk = CreateObject("Outlook.Application")
Set evn = objOlk.CreateItem(0)
evn.To = Range("f" & h)
'evn.CC = [h2].Value
'evn.BCC = [h3].Value
evn.Subject = Range("g" & h)
evngovde = "<br></br>" & "<a></a>" & _
Range("c" & h) & " " & "Yeni Yılda Yine <b> Kurumsal Market </b>" & _
"<br><br>*******Yeni Yılda Kartuş Toner ve Şerit İhtiyaçlarınız İçin Size Yepyeni Bir Fırsat" & _
"<br>*******En Ucuz Fiyatlarla Tekrar Karşınızdayız" & _
"<br>*******Kargo <b>SADECE 1,00 TL</b>" & _
"<br></br>" & _
"<br>*******Satın aldığınız her ürün adınıza faturalı olarak kapınıza gelir ve beğeninize sunulur.<br>" & _
"<br> <br>" & _
"<br><b>En Güvenli Ödeme Şekilleri :</b><br>" & _
"******-*Kapıda Ödeme<br>" & _
"******-*Kredi Kartı İle Ödeme<br>" & _
"******-*Hesaba Havale<br>"
' "<br><br><b>Üyelik Bilgileriniz :</b><br>" & _
"********Kullanıcı Mailiniz*:" & " " & Range("d" & h) & _
"<br>********Şifreniz****************:" & " " & Range("e" & h) & "<br><br>"
Set objEkle = evn.Attachments
Set objevn = objEkle.Add(strresmim)
evn.Close olSave
evn.HTMLBody = evngovde & "<br><IMG alt='' hspace=0 src='cid:'" & _
strresmim & "'' align=baseline border=0><br></BODY>"
evn.HTMLBody = evngovde & "<br><IMG alt='' hspace=0 src='cid:'" & _
strresmim & "'' align=baseline border=0><br></BODY>" & _
"<br><br>Erman USTA<br>" & _
"<b>Satış Temsilcisi</b><br>" & _
"0532 341 12 19<br><br>" & _
"<b>Online Sipariş için: www.KURUMSALmarket.com</b><br>" & _
"<br> <br>" & _
Range("c" & h) & " " & "*******Müşterilerimiz için ve verdileri referanslar doğrultusunda hazırladığımız bu mail, sizin daha iyi şartlar altında çalışmanızı sağlamak amacı ile gönderilmiştir. Eğer size yardımcı olmamızı istemiyorsanız bu mesaja 'istemiyorum' yazarak cevap verebilirsiniz.<br>"
evn.Save
'evn.Display
evn.send
strresmim = vbNullString
Set evn = Nothing: Set objOlk = Nothing
Set objevn = Nothing: Set objEkle = Nothing
evngovde = vbNullString: Set ek = Nothing
Next h
Application.ScreenUpdating = True
End Sub
----------------
birde bu makroyu çalıştırırken gönderim için satır sayısı istiyor bununda kalkması gerek sanırım.
ekte örnek dosyayı ekledim ilgilenen arkadaşlara duyurulur. teşekkür ederim.