Excel mail kısmında Body ile Html Body karıştırması

Cihan SK

Cihan SK

Katılım
20 Ocak 2017
Mesajlar
88
Excel Vers. ve Dili
Microsoft Excel 2013
Altın Üyelik Bitiş Tarihi
20.01.2019
Merhaba Arkadaşlar,

Mail gönderme konusunda bir konu takıldım. Mail gönderirken açıklama kısmı yani mailin içeriğini yazdığımız kısım ile digital imza kısmı birbirine karışıyor.
ben hem referans hücresindeki açıklama gelsin istiyorum. Hemde imzam bu açıklamanın altında çıksın istiyorum. İmza çıkınca açıklama çıkmıyor. açıklama çıkınca imza çıkmıyor.

Yardımcı olacak arkadaşlara çok teşekkürlerimi iletiyorum


Kod: 
Dim objOutlook As Object
    Dim objMail As Object
    Dim i As Long, NoA As Long
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    With objMail
        .To = Range("D4").Value & " ; " & Range("E4").Value & " ; " & Range("F4").Value & " ; " & Range("G4").Value
        .CC = Range("H4").Value
        .Subject = ""
        .Body = " ne olmalı "
        .Display
        '.HTMLBody = .HTMLBody & "<br><br><br>" & Signature.ReadAll
        .Save
        '.Send
    End With
 
H

hoguz2

Katılım
6 Ekim 2004
Mesajlar
250
Excel Vers. ve Dili
MSOffice 2010 TR
Altın Üyelik Bitiş Tarihi
19-11-2020
yeni bir alan ekleyip ikisini birlestirebilirsiniz srtbody & Signature.ReadAll vs gibi


Sub sorumail()



Dim objOutlook As Object
Dim objMail As Object
Dim i As Long, NoA As Long
Dim StrBody As String
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail


StrBody = Sheets("Sayfa2").Range("A1").Value & "<br>" & _
Sheets("Sayfa1").Range("A2").Value & "<br>" & _
Sheets("Sayfa1").Range("A3").Value & "<br><br><br>"


.To = Range("D4").Value & " ; " & Range("E4").Value & " ; " & Range("F4").Value & " ; " & Range("G4").Value
.CC = Range("H4").Value
.Subject = ""
.HTMLBody = StrBody
.Display
'.HTMLBody = .HTMLBody & "<br><br><br>" & Signature.ReadAll
.Save
'.Send
End With

End Sub
 
Cihan SK

Cihan SK

Katılım
20 Ocak 2017
Mesajlar
88
Excel Vers. ve Dili
Microsoft Excel 2013
Altın Üyelik Bitiş Tarihi
20.01.2019
Konu günceldir.

Oğuz bey,

kısmı imzamın gelmesine yetiyor.

Kod: 
.HTMLBody & "<br><br><br>" & Signature.ReadAll
.To
.CC
.Subject
kısımlarında bir sorun yok.
.Body olarak açıklama yazdığımda geliyor. Ama imzam gelmiyor. yazmadığımda boş bıraktığımda imzam geliyor. bu kısımda bana yardım lazım. ikisi beraber gelecek şekilde.
 
H

hoguz2

Katılım
6 Ekim 2004
Mesajlar
250
Excel Vers. ve Dili
MSOffice 2010 TR
Altın Üyelik Bitiş Tarihi
19-11-2020
hocam bendeki orjinal kodu kendi modulune yapistirip hic degistirmeden bir dener misin.

srtbody olarak a1 a2 a3 hucreleri tanimlanmis sekilde mailinin govdesine geldigini imzanin da geldigini goreceksin. outlook da imza olustur duysan ve yeni mail yaza tikladiginda imzan otomatik geliyorsa bu kodda da gelir.


Sub Mail_1()

Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)




strbody = Sheets("Sayfa1").Range("A1").Value & "<br>" & _
Sheets("Sayfa1").Range("A2").Value & "<br>" & _
Sheets("Sayfa1").Range("A3").Value & "<br><br><br>"

On Error Resume Next

With OutMail
.display
.To = "göndereceginiz mailler"
.CC = ""
.BCC = ""
.Subject = "konu alani"
.HTMLBody = strbody & "<br>" & .HTMLBody
.display
End With

On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
 
Cihan SK

Cihan SK

Katılım
20 Ocak 2017
Mesajlar
88
Excel Vers. ve Dili
Microsoft Excel 2013
Altın Üyelik Bitiş Tarihi
20.01.2019
Orjinal kullandığım kod bu şekilde

Kod: 
Sub KOD()
    
yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ActiveSheet.Name & "_" & Format(Now(), "yyyymmdd\_hhmm") & ".pdf"
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    yol, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Dim objOutlook As Object
    Dim objMail As Object
    Dim i As Long, NoA As Long
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    With objMail
        .To = Range("M1").Value & " ; " & Range("M2").Value & " ; " & Range("M3").Value & " ; " & Range("M4").Value & " ; " & Range("M5").Value
        .CC = Range("M2").Value
        .Subject = ""
        .Attachments.Add yol
        .display
        '.HTMLBody = .HTMLBody & "<br><br><br>" & Signature.ReadAll
        .Save
        '.Send
    End With
    
    Set objMail = Nothing
    Set objOutlook = Nothing
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
End Sub
Sizin vermiş olduğunuz kod normalde çalışıyor. Ancak bu kodlamanın içinde çalışması lazım. Biraz uğraştım. Ancak bir yerde bir sıkıntı var. yapamadım.

Kod: 
Sub KOD_2()

yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ActiveSheet.Name & "_" & Format(Now(), "yyyymmdd\_hhmm") & ".pdf"
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    yol, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
    
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Dim objOutlook As Object
Dim objApp As Object
Dim objMail As Object
Dim strbody As String
Dim i As Long, NoA As Long

Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)

[COLOR="Red"][B]strbody = Range("N1").Value & "<br>" & _
Range("N2").Value & "<br>" & _
Range("N3").Value & "<br><br><br>"[/B][/COLOR]

On Error Resume Next

With objMail
.display
.To = Range("M1").Value & " ; " & Range("M2").Value & " ; " & Range("M3").Value & " ; " & Range("M4").Value & " ; " & Range("M5").Value
.CC = ""
.BCC = ""
.Subject = ""
'.HTMLBody = strbody & "<br>" & .HTMLBody
.display
End With

On Error GoTo 0
Set objMail = Nothing
Set objOutlook = Nothing
End Sub
Renkli göstermiş olduğum kısımda başarılı olamadım. Mail normal açıyor. Ancak belirtilen adreste veriyi maile getirmiyor.
 
Cihan SK

Cihan SK

Katılım
20 Ocak 2017
Mesajlar
88
Excel Vers. ve Dili
Microsoft Excel 2013
Altın Üyelik Bitiş Tarihi
20.01.2019
Bu kodu son şekli bu şekilde ancak pdf maile eklenmiyor. Nedenini anlayamadım.

Kod: 
Sub KOD_2

yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ActiveSheet.Name & "_" & Format(Now(), "yyyymmdd\_hhmm") & ".pdf"
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    yol, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)




strbody = Range("N1").Value & "<br><br>" & _
Range("N2").Value & "<br>" & _
Range("N3").Value & ""
strbody = "<font size=""2"" face=""tahoma"">" & strbody & "</font>"

On Error Resume Next

With OutMail
.display
.To = Range("M1").Value & " ; " & Range("M2").Value & " ; " & Range("M3").Value & " ; " & Range("M4").Value & " ; " & Range("M5").Value
.CC = Range("M2").Value
.BCC = ""
.Subject = ""
.HTMLBody = strbody & "<br>" & .HTMLBody
.display
End With

On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
 
Son düzenleme:
Cihan SK

Cihan SK

Katılım
20 Ocak 2017
Mesajlar
88
Excel Vers. ve Dili
Microsoft Excel 2013
Altın Üyelik Bitiş Tarihi
20.01.2019
Yaptım. Çok teşekkürler oğuz bey örnek kod için :)

Kod: 
Sub KOD_2

yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ActiveSheet.Name & "_" & Format(Now(), "yyyymmdd\_hhmm") & ".pdf"
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    yol, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
    
With Application
      .EnableEvents = False
      .ScreenUpdating = False
End With
    
Dim objOutlook As Object
Dim ObjApp As Object
Dim ObjMail As Object
Dim strbody As String
Dim i As Long, NoA As Long

Set objOutlook = CreateObject("Outlook.Application")
Set ObjMail = objOutlook.CreateItem(0)

strbody = Range("N1").Value & "<br><br>" & _
Range("N2").Value & "<br>" & _
Range("N3").Value & ""
strbody = "<font size=""2"" face=""tahoma"">" & strbody & "</font>"

On Error Resume Next

With ObjMail
.display
.To = Range("M1").Value & " ; " & Range("M2").Value & " ; " & Range("M3").Value & " ; " & Range("M4").Value & " ; " & Range("M5").Value
.CC = Range("M2").Value
.BCC = ""
.Subject = ""
.Attachments.Add yol
.HTMLBody = strbody & "<br>" & .HTMLBody
.display
.Save
'.Send
End With

On Error GoTo 0
Set ObjMail = Nothing
Set ObjApp = Nothing

With Application
        .EnableEvents = True
        .ScreenUpdating = True
End With
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst