Body Kısmında Hücre Okutma

[baysevimli]

Değerli Arkadaşlar Merhaba,

Bir konuda yardımınıza ihtiyacım var. Aşağıda maillerş otomatik gönderen bir makrom var. .Body ( Gövde) kısmında aşağıdaki mantığı koda çeviremedim. özetle : Outlook gövesine "sabit metin"ler koddan, A1,A2,A3 hücrelerindeki bilgileride exceldeki hücrelerden almasını isitiyorum. Şimdiden teşekkür ederim.


.Body = "Sabit metin1" ("A1") "sabit metin2" ("A2") "sabit metin3" (A3)






Sub Mail_Songül()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = True
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
On Error Resume Next
With OutMail
.To = Range("A2")
.CC = Range("B2")
.BCC = Range("C2")
.Subject = Range("E2")
.Body = "Bu Kısım"
.Display
.Send
End With
.Close savechanges:=False
End With
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[Korhan Ayhan]

Aşağıdaki gibi deneyiniz...

.Body = Sheets("Sayfa1").Range("A1").Value & " " & Sheets("Sayfa1").Range("A2").Value & " " & Sheets("Sayfa1").Range("A3").Value

 

[baysevimli]

Korhan Bey,

Maalesef olmadı. Tam olarak istediğim şey : BODY kısmında aşağıdaki cümle yazacak ve A1,A2,A3 hüclerinden mevcut olan isim, saat, tarih, bilgilerimi tırnak içindeki yerlere hücrelerden alarak getirecek.

Sn. "A1" İş göremezlik belgeniz "A2" tarafımıza ulaşmıştır. Lütfen "A3" onaylatınız.

 

[Korhan Ayhan]

Aşağıdaki gibi deneyiniz...

.Body = "Sn. " & Sheets("Sayfa1").Range("A1").Text & " İş göremezlik belgeniz " & Sheets("Sayfa1").Range("A2").Text & " tarafımıza ulaşmıştır. Lütfen " & Sheets("Sayfa1").Range("A3").Text & " onaylatınız."

 

[baysevimli]

Korhan Bey,

Denedim çalışıyor. Çok teşekkür ederim.

 

[baysevimli]

Korhan Bey,

Afedersiniz ama istediğim tam olarak yine olmadı. ama ben yanlış ifade ettim kendimi.

BODY kısmında tam olarak istediğim şu ; aşağıda yazan mail gövdesinde tırnak içine aldığım yerleri belirleyeceğim excel hücrelerinden alacak ve aşağıdaki gibi satırlar arası boşluklar bırakarak gövdeyi oluşturacak. mesela sizin adınızın altında bir satır boşluk var.
Sizi baya uğraştırdım kusura bakmayın. ilginiz için teşekkür ederim.


Sn. "Korhan Ayhan"

"10.01.2016" Tarihli iş göremezlik belgeniz tarafımıza ulaşmıştır. "11.01.2016" Tarihinde iş başı yapmanız gerekmektedir.

E-Raporunuzun düştüğü tarih ve saat "10.01.2016 14:11"

Bilgilerinize arz ederim.

Saygılarımla.

İnsan Kaynakları

 

[Korhan Ayhan]

Aşağıdaki gibi deneyiniz...

.Body = "Sn. " & Sheets("Sayfa1").Range("A1").Text & Chr(10) & Chr(10) & _
        Sheets("Sayfa1").Range("A2").Text & " Tarihli iş göremezlik belgeniz tarafımıza ulaşmıştır. " & Sheets("Sayfa1").Range("A3").Text & " Tarihinde iş başı yapmanız gerekmektedir." & Chr(10) & Chr(10) & _
        "E-Raporunuzun düştüğü tarih ve saat " & Sheets("Sayfa1").Range("A4").Text & Chr(10)& Chr(10) & _
        "Bilgilerinize arz ederim." & Chr(10) & Chr(10) & _
        "Saygılarımla." & Chr(10) & Chr(10) & _
        "İnsan Kaynakları"

 

[baysevimli]

Korhan Bey,

İnceledim ancak, satırlar arasında boşluk vermiyor. tüm satırları aşağıdaki gibi bitişik yazdı. Ne yapabiliriz ?



Sn. Korhan Ayhan
15.01.2016 Tarihli iş göremezlik belgeniz tarafımıza ulaşmıştır. 16.01.2016 Tarihinde iş başı yapmanız gerekmektedir.
E-Raporunuzun düştüğü tarih ve saat 15.01.2016 14:11
Bilgilerinize arz ederim.
Saygılarımla.
İnsan Kaynakları

 

[Korhan Ayhan]

#7 nolu mesajımı güncelledim. Tekrar deneyiniz.

 

[baysevimli]

Korhan Bey,

Test ettim düzeldi. Çok teşekkür ederim. Çok uğraştırdım sizi hakkınızı helal edin ama bir sorum daha olacak. Ben koddaki sayfa numarası ve hücreleri değiştirdim. artık bilgileri tek satırdaki A1,B1,C1,D1 gibi hücrelerden alacak. sorum şu ; bende 50 satır var alt alta ve makromun aynı mantıkla her satırdaki bilgileri mail atmasını nasıl sağlayabiliriz ? ben mesela A1 hücresini A:A yaptım ama toplu atmadı.

Sub Mail_Songül()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = True
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
On Error Resume Next
With OutMail
.To = Range("K1")
.CC = Range("L1")
.BCC = Range("")
.Subject = Range("L1")
.Body = "Sn. " & Sheets("Sayfa3").Range("A1").Text & Chr(10) & Chr(10) & _
        Sheets("Sayfa3").Range("B1").Text & " Tarihli iş göremezlik belgeniz tarafımıza ulaşmıştır. " & Sheets("Sayfa3").Range("C1").Text & " Tarihinde iş başı yapmanız gerekmektedir." & Chr(10) & Chr(10) & _
        "E-Raporunuzun düştüğü tarih ve saat " & Sheets("Sayfa3").Range("D1").Text & Chr(10) & Chr(10) & _
        "Bilgilerinize arz ederim." & Chr(10) & Chr(10) & _
        "Saygılarımla." & Chr(10) & Chr(10) & _
        "İnsan Kaynakları"
.Display
.Send
End With
.Close savechanges:=False
End With
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[Korhan Ayhan]

Her satıra göre kodunuzdaki hangi bölümler değişecek? Belirtirseniz düzenlemeye çalışırım.

 

[baysevimli]

Korhan Bey Günaydın,

Benim Outlook'uma her gün SGK'dan 30-40 rapor geliyor. Bu kod yardımıyla A1,B1,C1, ve D1 hücrelerine outlook mail gövde kısmından isim,rapor tarihi,işbaşı tarihi ve saat bilgilerimi çekiyorum. İstediğim şu; Body kısmında tırnak içinde yer alan cümleler hep sabit olacak ve hücrelerden aldığı verilerle ilgili kısımları doldurarak E1 sütunundaki adreslere mail atacak. Şuan kodun bu haliyle A1 satırındaki bilgilere mail atıyor. ama benim hergün 30-40 satırım daha oluşuyor. her satırdaki bilgileri toplu mail atmasını istiyorum. Bir de bu kod sayesinde bir boton yardımıyla outlookdaki maillerden istediğim kısımları excele alıyorum. excele alma islemini butonunu kullanarak manuel yapıyorum. her 10 dakikada bir otomatik kendisinin kontrol edip dataları alması mümkünmü? Bunları yapabilirsek harika olacak. Destekleriniz için çok teşekkür ederim. Kodun şuanki hali aşağıdaki gibidir.

Sub Mail_Songül()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = True
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
On Error Resume Next
With OutMail
.To = Range("K1")
.CC = Range("L1")
.BCC = Range("")
.Subject = Range("E1")
.Body = "Sn. " & Sheets("Sayfa3").Range("A1").Text & Chr(10) & Chr(10) & _
        Sheets("Sayfa3").Range("B1").Text & " Tarihli iş göremezlik belgeniz tarafımıza ulaşmıştır. " & Sheets("Sayfa3").Range("C1").Text & " Tarihinde iş başı yapmanız gerekmektedir." & Chr(10) & Chr(10) & _
        "E-Raporunuzun düştüğü tarih ve saat " & Sheets("Sayfa3").Range("D1").Text & Chr(10) & Chr(10) & _
        "Bilgilerinize arz ederim." & Chr(10) & Chr(10) & _
        "Saygılarımla." & Chr(10) & Chr(10) & _
        "İnsan Kaynakları"
.Display
.Send
End With
.Close savechanges:=False
End With
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[baysevimli]

Korhan Bey,

Yardımlarınızı rica ederim.

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Aktif sayfadaki hücreleri dikkate alır. Sayfa adı gerekiyorsa hücre adreslerinin önüne ekleme yapmak gerekir.

Eğer sonuç alamazsanız lütfen örnek dosyanızı ekleyiniz. İşlem adımlarını dosyanız üzerinden tarif ediniz.

Sub Mail_Gonder()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim S1 As Worksheet
    
    Set S1 = Sheets("Sayfa3")
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
        
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    On Error Resume Next
    
    For X = 1 To 50
        With OutMail
            .TO = Cells(X, "K")
            .CC = Cells(X, "L")
            .BCC = ""
            .Subject = Cells(X, "E")
            .Body = "Sn. " & S1.Range("A1").Text & Chr(10) & Chr(10) & _
                    S1.Range("B1").Text & " Tarihli iş göremezlik belgeniz tarafımıza ulaşmıştır. " & S1.Range("C1").Text & " Tarihinde iş başı yapmanız gerekmektedir." & Chr(10) & Chr(10) & _
                    "E-Raporunuzun düştüğü tarih ve saat " & S1.Range("D1").Text & Chr(10) & Chr(10) & _
                    "Bilgilerinize arz ederim." & Chr(10) & Chr(10) & _
                    "Saygılarımla." & Chr(10) & Chr(10) & _
                    "İnsan Kaynakları"
            .Display
            .Send
        End With
    Next
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub