Excelden e-mail nasıl yollarım

search77 · 2 Aralık 2008

Arkadaşlar merhaba,

Ekli dosyamda bir tablo var, orada mail gidecek kişiler ve mail içeriğide mevcut, ben bunu macro ile tek tek nasıl yollayabilirm.

Yardımcı olucaklara şimdiden çok çok teşekkür ederim.

Saygı ve sevglerimle.

Haluk · 2 Aralık 2008

Filtrelemeyi yaptıktan sonra, aşağıdaki makroyu çalıştırıp deneyebilirsiniz...

Kod:

Sub Test()
    Dim OutlookApp As Object, OutlookMsg As Object
    Dim MyBody As String
    Dim lRow As Long
    
    lRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    
    MyBody = ActiveSheet.Range("I" & lRow) & vbCrLf & vbCrLf
    MyBody = MyBody & "Şube : " & ActiveSheet.Range("A" & lRow) & vbCrLf
    MyBody = MyBody & "İsim : " & ActiveSheet.Range("B" & lRow) & vbCrLf
    MyBody = MyBody & "Soyad : " & ActiveSheet.Range("C" & lRow) & vbCrLf
    MyBody = MyBody & "Adres : " & ActiveSheet.Range("D" & lRow) & vbCrLf
    
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMsg = OutlookApp.CreateItem(0)
    
    With OutlookMsg
        .Body = MyBody
        .Subject = ActiveSheet.Range("H" & lRow)
        .To = ActiveSheet.Range("E" & lRow)
        .CC = ActiveSheet.Range("F" & lRow) & ";" & ActiveSheet.Range("G" & lRow)
        .Send
    End With
        
    Set OutlookMsg = Nothing
    Set OutlookApp = Nothing
End Sub

search77 · 3 Aralık 2008

Haluk bey,

Filitreleme derken yani filitreyi seçtikten sonramı macro tuşuna basıcam, ya da örnek bir dosya yollayabilir misiniz?

Saygılarımla.

Haluk · 3 Aralık 2008

Filtreleme işini çalışma sayfasına siz koymuşunuz, benimle bir ilgisi yok.

Dolayısiyle, örneğin sayfadaki ad sütunundan bir seçim yaptıktan sonra module yerleştirdiğiniz makroyu çalıştırın.

Sayfa üzerindeki e-mail adresleri geçerli adreslerese bir sorun olmadan e-mail gider...

.

search77 · 3 Aralık 2008

Haluk bey macro okey, süper olmuş, fakat mailin içeriğini tablo şeklinde yapamaz mıyız?

Sube Ad Soyad Adres
2 Ahmet Zan Mersin
2 Ali Çelik Hatay

Yani bu şekilde ve tablo çizgileri olacak şekilde yapma imkanımız yok mu?

Saygılar

baydeniro · 3 Aralık 2008

Paylaşım için teşekkürler

Haluk · 3 Aralık 2008

Tablo olarak da olur ama sistem kaynaklarını biraz zorladığı için ( en azından benim PC de öyle) vazgeçtim.

.

search77 · 3 Aralık 2008

Haluk bey benim PC biraz iyi belki ben yapabilirim yardımcı olabilirseniz? Aslında filitre yaptıktan sonra o bilgileri copy edip outlook içine paste etse yine yeterli bunu yapabilir miyiz?

Haluk · 3 Aralık 2008

Evet.... şimdi yapmanız gereken, daha önce verdiğim makroyu silip, yerine aşağıdakini yerleştirmek olacak.

Daha sonra yine filtreleme işini yaptıktan sonra söz konusu makroyu çalıştırıp, deneyin....

Kod:

Sub Test()
    Dim OutlookApp As Object, OutlookMsg As Object
    Dim FSO As Object
    Dim BodyText1 As Object, BodyText2, BodyText3 As Object
    Dim MyRange As Range
    Dim TempFile1 As String, TempFile2, TempFile3 As String
    Dim lRow As Long
    lRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    
    TempFile1 = "C:\TempHTML1.htm"
    TempFile2 = "C:\TempHTML2.htm"
    TempFile3 = "C:\TempHTML3.htm"
    
    Set FSO = CreateObject("Scripting.FilesystemObject")
    
    On Error Resume Next
    
    Set MyRange = ActiveSheet.Range("A" & lRow & ":D" & lRow)
    If MyRange Is Nothing Then Exit Sub
    ActiveWorkbook.PublishObjects.Add _
    (4, TempFile1, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
    
    Set MyRange = ActiveSheet.Range("I" & lRow)
    ActiveWorkbook.PublishObjects.Add _
    (4, TempFile2, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
    
    Set MyRange = ActiveSheet.Range("A1:D1")
    ActiveWorkbook.PublishObjects.Add _
    (4, TempFile3, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMsg = OutlookApp.CreateItem(0)
    Set BodyText1 = FSO.OpenTextFile(TempFile1, 1)
    Set BodyText2 = FSO.OpenTextFile(TempFile2, 1)
    Set BodyText3 = FSO.OpenTextFile(TempFile3, 1)
    
    With OutlookMsg
        .HTMLBody = BodyText2.ReadAll & BodyText3.ReadAll & BodyText1.ReadAll
        .Subject = ActiveSheet.Range("H" & lRow)
        .To = ActiveSheet.Range("E" & lRow)
        .CC = ActiveSheet.Range("F" & lRow) & ";" & ActiveSheet.Range("G" & lRow)
        .Send
'        .Display
    End With
        
    Kill TempFile1
    Kill TempFile2
    Kill TempFile3
    
    Set BodyText3 = Nothing
    Set BodyText2 = Nothing
    Set BodyText1 = Nothing
    Set OutlookMsg = Nothing
    Set OutlookApp = Nothing
    Set MyRange = Nothing
    Set FSO = Nothing
End Sub

search77 · 3 Aralık 2008

Haluk bey bence süper olmuş, fakat eksik çalışan tek şey görüntüyü ve mail içeriğini outlookta mailin tam ortasına getiriyor, sola yaslama yapamaz mıyız mail o şekilde gitse.

Saygılarımla.

Haluk · 3 Aralık 2008

Mesaj gövdesinin sola dayalı olması için yapılan revizyon aşağıdadır.

Artık bankadan +1% verirsiniz.... :mrgreen:

.

Kod:

Sub Test()
    Dim OutlookApp As Object, OutlookMsg As Object
    Dim FSO As Object
    Dim BodyText1 As Object, BodyText2, BodyText3 As Object
    Dim MyRange As Range
    Dim TempFile1 As String, TempFile2, TempFile3 As String
    Dim strHTMLBody As String
    Dim lRow As Long
    lRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    
    TempFile1 = "C:\TempHTML1.htm"
    TempFile2 = "C:\TempHTML2.htm"
    TempFile3 = "C:\TempHTML3.htm"
    
    Set FSO = CreateObject("Scripting.FilesystemObject")
    
    On Error Resume Next
    
    Set MyRange = ActiveSheet.Range("A" & lRow & ":D" & lRow)
    If MyRange Is Nothing Then Exit Sub
    ActiveWorkbook.PublishObjects.Add _
    (4, TempFile1, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
    
    Set MyRange = ActiveSheet.Range("I" & lRow)
    ActiveWorkbook.PublishObjects.Add _
    (4, TempFile2, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
    
    Set MyRange = ActiveSheet.Range("A1:D1")
    ActiveWorkbook.PublishObjects.Add _
    (4, TempFile3, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMsg = OutlookApp.CreateItem(0)
    Set BodyText1 = FSO.OpenTextFile(TempFile1, 1)
    Set BodyText2 = FSO.OpenTextFile(TempFile2, 1)
    Set BodyText3 = FSO.OpenTextFile(TempFile3, 1)
    
    strHTMLBody = BodyText2.ReadAll & BodyText3.ReadAll & BodyText1.ReadAll
    strHTMLBody = Replace(strHTMLBody, "align=center", "align=left", , , vbTextCompare)
    
    With OutlookMsg
        .HTMLBody = strHTMLBody
        .Subject = ActiveSheet.Range("H" & lRow)
        .To = ActiveSheet.Range("E" & lRow)
        .CC = ActiveSheet.Range("F" & lRow) & ";" & ActiveSheet.Range("G" & lRow)
        .Send
'        .Display
    End With
        
    Kill TempFile1
    Kill TempFile2
    Kill TempFile3
    
    Set BodyText3 = Nothing
    Set BodyText2 = Nothing
    Set BodyText1 = Nothing
    Set OutlookMsg = Nothing
    Set OutlookApp = Nothing
    Set MyRange = Nothing
    Set FSO = Nothing
End Sub

search77 · 3 Aralık 2008

Haluk bey herşey süper, fakat filitre yaptığımda TO kısma yazacak kişiye ait 2 veya daha fazla kayıt varken burda tek bir kayıt çıkıyor, yani hepsinde öyle 1 kayıt maile atıyor halbuki kişiye birden fazla kayıt ait

Haluk · 3 Aralık 2008

Mail adresleri doğruysa, gönderdiğiniz dosyadaki verilere göre;

To: 1 adet mail adresi

CC : 2 adet mail adresi

mesajda yer alır.

Sizdeki dosya, buraya eklediğinizden değişikse.... bilemiyorum.

.

Haluk · 3 Aralık 2008

Bu arada, filtreleme (süzme) işini "To" değil, "Ad" veya "Soyad" sütunlarında yapmanız gerekiyor.

Daha doğrusu, şöyle söyleyeyim.... bu kod, süzme işi yapıldıktan sonra sayfadaki son satırda yer alan verileri esas alır.

.

Haluk · 3 Aralık 2008

Eğer filtreleme (süzme) işini "To" sütununa göre yaparsanız ve birden fazla aynı mail adresi varsa, daha önce dediğim gibi sadece son satırdaki veriler dikkate alınmaktaydı.

Bahsettiğiniz durumu da dikkate alınarak yapılan son revizyonda bu kez, süzme sonucunda çıkan tüm adreslere ilgili mail gönderilmektedir. (1 adet mail penceresinde değil, süzme sonucunda kaç adet veri çıktıysa, o kadar adet maikl gönderilmektedir.)

Revize kodlar aşağıdadır...

.

Kod:

Sub Test()
    Dim OutlookApp As Object, OutlookMsg As Object
    Dim FSO As Object
    Dim BodyText1 As Object, BodyText2, BodyText3 As Object
    Dim MyRange As Range
    Dim TempFile1 As String, TempFile2, TempFile3 As String
    Dim strHTMLBody As String
    Dim lRow As Long
    Dim aRng As Range
    TempFile1 = "C:\TempHTML1.htm"
    TempFile2 = "C:\TempHTML2.htm"
    TempFile3 = "C:\TempHTML3.htm"
 
    Set FSO = CreateObject("Scripting.FilesystemObject")
 
    For Each aRng In Range("A1:A1000").Cells.SpecialCells(xlCellTypeVisible)
        On Error Resume Next
        If aRng <> Empty And aRng <> "Sube" Then
            lRow = aRng.Row
            Set MyRange = ActiveSheet.Range("A" & lRow & ":D" & lRow)
            If MyRange Is Nothing Then Exit Sub
            ActiveWorkbook.PublishObjects.Add _
            (4, TempFile1, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
 
            Set MyRange = ActiveSheet.Range("I" & lRow)
            ActiveWorkbook.PublishObjects.Add _
            (4, TempFile2, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
 
            Set MyRange = ActiveSheet.Range("A1:D1")
            ActiveWorkbook.PublishObjects.Add _
            (4, TempFile3, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
 
            Set OutlookApp = CreateObject("Outlook.Application")
            Set OutlookMsg = OutlookApp.CreateItem(0)
            Set BodyText1 = FSO.OpenTextFile(TempFile1, 1)
            Set BodyText2 = FSO.OpenTextFile(TempFile2, 1)
            Set BodyText3 = FSO.OpenTextFile(TempFile3, 1)
 
            strHTMLBody = BodyText2.ReadAll & BodyText3.ReadAll & BodyText1.ReadAll
            strHTMLBody = Replace(strHTMLBody, "align=center", "align=left", , , vbTextCompare)
 
            With OutlookMsg
                .HTMLBody = strHTMLBody
                .Subject = ActiveSheet.Range("H" & lRow)
                .To = ActiveSheet.Range("E" & lRow)
                .CC = ActiveSheet.Range("F" & lRow) & ";" & ActiveSheet.Range("G" & lRow)
                .Send
'                .Display
            End With
 
            Kill TempFile1
            Kill TempFile2
            Kill TempFile3
        End If
    Next
 
    Set BodyText3 = Nothing
    Set BodyText2 = Nothing
    Set BodyText1 = Nothing
    Set OutlookMsg = Nothing
    Set OutlookApp = Nothing
    Set MyRange = Nothing
    Set FSO = Nothing
End Sub

search77 · 3 Aralık 2008

Haluk bey bu sefer doğru, fakat ben TO kısmında filitre yapmak istiyorum, yani TO kısmında
örnek

Sube Ad Soyad Adres TO Outlook ta mailin to kısmına yazılacak isim
2 Ahmet Zan Mersin ahmet.hasan@yyy.com
2 Ali Çelik Hatay ahmet.hasan@yyy.com

ahmet.hasan@yyy.com seçtiğimde bu 2 kayıtı alacak ve burda yanında CC hücrelerde ne isim varsa onları sadece CC ye ekleyecek. yani amacım TO kısımdaki isme göre filitre yapacak bu kişiye kaç kayıt çıkarsa onları maile ekleyecek.

Çok uğraştırdım sizi kusura bakmayın

Saygılarımla.

search77 · 4 Aralık 2008

Arkadaşlar haluk bey bayağı yardımcı oldu, son olarak yukarıda eklediğim bilgi şeklinde macroyu nasıl yapabiliriz?

Saygılarımla.

Haluk · 4 Aralık 2008

En son verdiğim kod zaten bu işi yapıyor.

Sizin istediğinizden farkı; tek mail ile değil de süzme sonucunda kaç adet kayıt çıkıyorsa o kadar adet mail gidiyor.

Bu işinize yaramıyor mu ?

.

search77 · 4 Aralık 2008

Haluk bey,

Öncelikle ilginize çok teşekkür ediyorum, benim istediğim TO kısmındaki kişi mailin sadece TO ksımında olacak CC dekiler hiç önemli değil yani TO da kişinin CC deki karşılıkları farklı kişiler olması imkansız yani özetlersek;

TO CC CC
Ahmet Ali Ayşe ............... CC ler deki ilk kısmı alması yeterli.
Ahmet Ali Ayşe ...............

Fakat TO kısmına göre filitre yapacak kaç kayıt çıkarsa TO kısmındaki kişiye ait bu kişinin ismini TO kısıma yazacak CC lerdeki ilk kayıt isimleri alması yeterli CC ye yazacak,

mail içeriğinide TO daki Ahmete bağlı kaç kayıt gelirse (2,5,3 veya daha fazla) bu bilgiler gelecek.

Saygılarımla.

Haluk · 4 Aralık 2008

Tam anlamadım belki ama, bir de şunu deneyin...

Kod:

Sub Test()
    Dim OutlookApp As Object, OutlookMsg As Object
    Dim FSO As Object
    Dim BodyText1 As Object, BodyText2, BodyText3 As Object
    Dim MyRange As Range
    Dim TempFile1 As String, TempFile2, TempFile3 As String
    Dim strHTMLBody As String, strCC As String
    Dim lRow As Long
    Dim aRng As Range
    TempFile1 = "C:\TempHTML1.htm"
    TempFile2 = "C:\TempHTML2.htm"
    TempFile3 = "C:\TempHTML3.htm"
    
    Set FSO = CreateObject("Scripting.FilesystemObject")
    
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMsg = OutlookApp.CreateItem(0)
    
    For Each aRng In Range("A1:A1000").Cells.SpecialCells(xlCellTypeVisible)
        On Error Resume Next
        If aRng <> Empty And aRng <> "Sube" Then
            lRow = aRng.Row
            Set MyRange = ActiveSheet.Range("A" & lRow & ":D" & lRow)
            If MyRange Is Nothing Then Exit Sub
            ActiveWorkbook.PublishObjects.Add _
            (4, TempFile1, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
            
            Set MyRange = ActiveSheet.Range("I" & lRow)
            ActiveWorkbook.PublishObjects.Add _
            (4, TempFile2, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
            
            Set MyRange = ActiveSheet.Range("A1:D1")
            ActiveWorkbook.PublishObjects.Add _
            (4, TempFile3, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
        
            Set BodyText1 = FSO.OpenTextFile(TempFile1, 1)
            Set BodyText2 = FSO.OpenTextFile(TempFile2, 1)
            Set BodyText3 = FSO.OpenTextFile(TempFile3, 1)
            
            strHTMLBody = strHTMLBody & BodyText1.ReadAll
            
            strCC = strCC & ActiveSheet.Range("F" & lRow) & ";" & ActiveSheet.Range("G" & lRow) & ";"
            
            Kill TempFile1
            Kill TempFile2
            Kill TempFile3
        End If
    Next
    
    strHTMLBody = BodyText2.ReadAll & BodyText3.ReadAll & strHTMLBody
    strHTMLBody = Replace(strHTMLBody, "align=center", "align=left", , , vbTextCompare)
    With OutlookMsg
        .HTMLBody = strHTMLBody
        .Subject = ActiveSheet.Range("H" & lRow)
        .To = ActiveSheet.Range("E" & lRow)
        .CC = strCC
        .Send
'        .Display
    End With
            
    Set BodyText3 = Nothing
    Set BodyText2 = Nothing
    Set BodyText1 = Nothing
    Set OutlookMsg = Nothing
    Set OutlookApp = Nothing
    Set MyRange = Nothing
    Set FSO = Nothing
End Sub

Excelden e-mail nasıl yollarım

search77

Ekli dosyalar

Haluk

𐱅𐰇𐰼𐰚

search77

Haluk

𐱅𐰇𐰼𐰚

search77

baydeniro

Haluk

𐱅𐰇𐰼𐰚

search77

Haluk

𐱅𐰇𐰼𐰚

search77

Haluk

𐱅𐰇𐰼𐰚

search77

Haluk

𐱅𐰇𐰼𐰚

Haluk

𐱅𐰇𐰼𐰚

Haluk

𐱅𐰇𐰼𐰚

search77

search77

Haluk

𐱅𐰇𐰼𐰚

search77

Haluk

𐱅𐰇𐰼𐰚