Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Makro-VBA
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Makro-VBA Makro veya VBA ile ilgili sorularınızı buraya gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 21-04-2017, 08:57   #1
Cihan SK
Altın Üye
 
Giriş: 20/01/2017
Mesaj: 57
Excel Vers. ve Dili:
Excel 2010
Varsayılan Excel mail kısmında Body ile Html Body karıştırması

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: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
Cihan SK Çevrimdışı   Alıntı Yaparak Cevapla
Eski 21-04-2017, 12:11   #2
hoguz2
 
Giriş: 06/10/2004
Şehir: Antalya
Mesaj: 92
Excel Vers. ve Dili:
MSOffice 2010 TR
Varsayılan

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
hoguz2 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 21-04-2017, 14:17   #3
Cihan SK
Altın Üye
 
Giriş: 20/01/2017
Mesaj: 57
Excel Vers. ve Dili:
Excel 2010
Varsayılan

Konu günceldir.

Oğuz bey,

kısmı imzamın gelmesine yetiyor.

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
.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.
Cihan SK Çevrimdışı   Alıntı Yaparak Cevapla
Eski 21-04-2017, 15:12   #4
hoguz2
 
Giriş: 06/10/2004
Şehir: Antalya
Mesaj: 92
Excel Vers. ve Dili:
MSOffice 2010 TR
Varsayılan

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
hoguz2 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 22-04-2017, 07:42   #5
Cihan SK
Altın Üye
 
Giriş: 20/01/2017
Mesaj: 57
Excel Vers. ve Dili:
Excel 2010
Varsayılan

Orjinal kullandığım kod bu şekilde

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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>" & _
Range("N2").Value & "<br>" & _
Range("N3").Value & "<br><br><br>"

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 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 24-04-2017, 07:24   #6
Cihan SK
Altın Üye
 
Giriş: 20/01/2017
Mesaj: 57
Excel Vers. ve Dili:
Excel 2010
Varsayılan

Bu kodu son şekli bu şekilde ancak pdf maile eklenmiyor. Nedenini anlayamadım.

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
  
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

Bu mesaj en son " 24-04-2017 " tarihinde saat 07:31 itibariyle Cihan SK tarafından düzenlenmiştir....
Cihan SK Çevrimdışı   Alıntı Yaparak Cevapla
Eski 24-04-2017, 07:41   #7
Cihan SK
Altın Üye
 
Giriş: 20/01/2017
Mesaj: 57
Excel Vers. ve Dili:
Excel 2010
Varsayılan

Yaptım. Çok teşekkürler oğuz bey örnek kod için

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
 
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
Cihan SK Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 02:27


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Hurda - Torna - Çorlu Web Tasarım - Tarot Falı - Fenerbahçe Haberleri - Trakya Haberleri - Investing - Hurda - Kobi Danışmanlık - Tekirdağ Samsung - Kozmetik Ürünler - Sağlıklı Makyaj Ürünleri - Yaşlanma Karşıtı Ürünler - Excel Eğitimi - Çorlu OSGB - Lingerie - Dyeing Machine - Çorlu Temizlik- Didim Çatı İnşaat- Çorlu Ambar- Hava Çekimi- Hazır Site- SEO- Çorlu Estetik
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden