Mail Gövde ve Mail Adres hücreden alma

[ozgurpeh]

Merhaba Arkadaşlar,

Forumda örneklerini gördüm fakat tam istediğim sonucu bulamadım. Aşağıdaki koda CC mail adresine Sayfa2 C3 hücresini ve Mail Body alanına default yazı haricinde Sayfa1 c30:d37 hücresini kopyalamak istiyorum. Kodu nasıl düzenlemem gerektiği konusunda yardımcı olabilir misiniz?

Şimdiden teşkkürler


Sub Order()
Dim olApp As Object
Dim olMail As Object
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(0)
ThisWorkbook.Sheets("Siparis").Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "Liste.xlsx"
With olMail
'.SentOnBehalfOfName = "xxx@xxx.com"
.BCC = "xxx@xxxl.com"
.CC = "xxx@sss.com
.Subject = "Liste1r"
'.BCC = "ttt@yyy.com"
'.Body = "Liste güncellenmiştir.Lütfen kontrol ediniz." & Chr(10) & Chr(10) & "Sheets("ANA EKRAN").Range(["C3037"])"& Chr(13) & Chr(13) & "Tesekkürler."
.Attachments.Add ActiveWorkbook.FullName
.Display
'.Send
End With
ActiveWorkbook.Close False
Kill ThisWorkbook.Path & "\" & "Liste.xlsx"
Set olMail = Nothing
Set olApp = Nothing
End Sub

 

[turist]

Aşağıdaki kodlarla deneyin.

Sub Order()
Dim icerik As Range
Dim olApp As Object
Dim olMail As Object
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(0)
ThisWorkbook.Sheets("Siparis").Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "Liste.xlsx"
Set icerik = Nothing
On Error Resume Next
Set icerik = Sheets("ANA EKRAN").Range("c30:D37")
On Error GoTo 0
With olMail
'.SentOnBehalfOfName = "xxx@xxx.com"
.BCC = "xxx@xxxl.com"
.CC = Sheets("Sayfa2").Range("C3")
.Subject = "Liste1r"
'.BCC = "ttt@yyy.com"
.HTMLBody = "Liste güncellenmiştir.Lütfen kontrol ediniz." & Chr(10) & Chr(10) & RangetoHTML(icerik) & Chr(13) & Chr(13) & "Tesekkürler."
.Attachments.Add ActiveWorkbook.FullName
.Display
'.Send
End With
ActiveWorkbook.Close False
Kill ThisWorkbook.Path & "\" & "Fuels_order.xlsx"
Set olMail = Nothing
Set olApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[ozgurpeh]

Sub Order() Dim icerik As Range Dim olApp As Object Dim olMail As Object Set olApp = CreateObject("Outlook.Application") Set olMail = olApp.CreateItem(0) ThisWorkbook.Sheets("Siparis").Copy ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "Liste.xlsx" Set icerik = Nothing On Error Resume Next Set icerik = Sheets("ANA EKRAN").Range("c3037") On Error GoTo 0 With olMail '.SentOnBehalfOfName = "xxx@xxx.com" .BCC = "xxx@xxxl.com" .CC = Sheets("Sayfa2").Range("C3") .Subject = "Liste1r" '.BCC = "ttt@yyy.com" .HTMLBody = "Liste güncellenmiştir.Lütfen kontrol ediniz." & Chr(10) & Chr(10) & RangetoHTML(icerik) & Chr(13) & Chr(13) & "Tesekkürler." .Attachments.Add ActiveWorkbook.FullName .Display '.Send End With ActiveWorkbook.Close False Kill ThisWorkbook.Path & "\" & "Liste.xlsx" Set olMail = Nothing Set olApp = Nothing End Sub Function RangetoHTML(rng As Range) Dim fso As Object Dim ts As Object Dim TempFile As String Dim TempWB As Workbook TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm" rng.Copy Set TempWB = Workbooks.Add(1) With TempWB.Sheets(1) .Cells(1).PasteSpecial Paste:=8 .Cells(1).PasteSpecial xlPasteValues, , False, False .Cells(1).PasteSpecial xlPasteFormats, , False, False .Cells(1).Select Application.CutCopyMode = False On Error Resume Next .DrawingObjects.Visible = True .DrawingObjects.Delete On Error GoTo 0 End With With TempWB.PublishObjects.Add( _ SourceType:=xlSourceRange, _ Filename:=TempFile, _ Sheet:=TempWB.Sheets(1).Name, _ Source:=TempWB.Sheets(1).UsedRange.Address, _ HtmlType:=xlHtmlStatic) .Publish (True) End With Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) RangetoHTML = ts.readall ts.Close RangetoHTML = Replace(RangetoHTML, "align=center xublishsource=", _ "align=left xublishsource=") TempWB.Close savechanges:=False Kill TempFile Set ts = Nothing Set fso = Nothing Set TempWB = Nothing End Function

Resimdeki hata geldi

 

[turist]

Function kısmında
"rng" yazan yerleri


"icerik"

olarak değiştirin.
Ayrıca "ANA EKRAN" sayfasında C3037 alanı boş olmamalıdır. Dikkat ediniz.

 

[ozgurpeh]

Function kısmında
"rng" yazan yerleri


"icerik"

olarak değiştirin.
Ayrıca "ANA EKRAN" sayfasında C3037 alanı boş olmamalıdır. Dikkat ediniz.

yine aynı yerde hata verdi

 

[turist]

Kodlar "Modüle" kısmında yazılı olmalıdır.
Tekrar hata alırsanız, örnek excel dosyanızı ekleyiniz.

 

[ozgurpeh]

Kodlar "Modüle" kısmında yazılı olmalıdır.
Tekrar hata alırsanız, örnek excel dosyanızı ekleyiniz.

ilk yolladığın hali ile örnek dosyayı koydum. Sayfa2 mail eki olacak Sayfa1 C3037 de gövdeye yapışacak default metinden sonra

 

[turist]

ilk yolladığın hali ile örnek dosyayı koydum. Sayfa2 mail eki olacak Sayfa1 C3037 de gövdeye yapışacak default metinden sonra

Sayın @ozgurpeh
#1. Nolu mesajınızda "mail eki" olarak bir bilgi vermemiştiniz.
Ekli dosyanıza uygun, düzeltilen dosya eklidir.
Bundan sonraki düzenleme ve değişiklikleri kendiniz uyarlayınız.
İyi çalışmalar.

 

[ozgurpeh]

Sayın @ozgurpeh
#1. Nolu mesajınızda "mail eki" olarak bir bilgi vermemiştiniz.
Ekli dosyanıza uygun, düzeltilen dosya eklidir.
Bundan sonraki düzenleme ve değişiklikleri kendiniz uyarlayınız.
İyi çalışmalar.

Harika olmuş emeğinize sağlık. Son bir ricam olacak, aşağıdaki alanı çalıştıramadım burda düzenleme yapılması gereken bir yer varmı ? cc ye sayfa2 de c3 hücresinde bulunan mail adresi aksın istiyorum

.CC = Sheets("Sayfa2").Range("C3")

 

[turist]

Harika olmuş emeğinize sağlık. Son bir ricam olacak, aşağıdaki alanı çalıştıramadım burda düzenleme yapılması gereken bir yer varmı ? cc ye sayfa2 de c3 hücresinde bulunan mail adresi aksın istiyorum

.CC = Sheets("Sayfa2").Range("C3")

Sayfa 2 C3 hücresine geçerli bir e-mail adresi yazın.