Güzel bir hafta dileyerek sözüme başlamak istedim.
Arkadaşlar benim bir sorunum vardı ve bu sorunu bir türlü çözemedim. Eski başlık altından devam edecektim ama onuda bulamadığım için tekrar başlık açmak zorunda kaldım kusura bakmayın.
Ben bir çalışma kitabında aktif sheet içerisinde yer alan tabloyu mailin içine aktarmak istiyorum. Ancak tablonun mesela "G1" sütununda yazılan açıklamayıda hemen altına yazdırmasını istiyorum. Sheeti dosya olarak göndermek bir çözüm ama iş görmediğinden direkt mailin içerisine yazdırılması gerekmekte. Bu arada mailin içerisine aktarılan tablo ve açıklama sola yanışık vaziyette olması gerekiyor.
Aşağıdaki kod bir önceki çalışmada yapılan koddur. Ancak bu kodla maalesef tabloyu mailin içine yazdırmayı başardım (ancak sola yanaşık değil ortalayarak yazdı) ancak bir türlü "G1" hücresine girilen açıklamayı tablonun altına yazdıramadım. Başka bilgisayarda çalışıyormuş ancak nedense benimkinde ne yaptımsa çalışmadı. Ben C sürücüsünü kullanamıyorum. (C sürücüsü kısıtlaması var) Belki ondan oluyor dedim ama belki sizlerin yazacağı başka bir kodla bu sorunu çözmem mümkün olur diye düşündüm.
Aşağıda hazırlanan kodu veriyorum. Bu arada tablonun "A1:F65536" aralığında olduğu varsayılmış ve açıklamanında "G1" de olduğu varsayılmıştır.
Ãimdiden teşekkürler
Sub EmailSheet3()
Dim OutlookApp As Object, OutlookMsg As Object
Dim FSO As Object
Dim BodyText1 As Object, BodyText2 As Object
Dim MyRange As Range
Dim TempFile1 As String, TempFile2 As String
Dim NoF As Long
NoF = Range("F65536").Cells.End(xlUp).Row
TempFile1 = "E:\TempHTML1.htm"
TempFile2 = "E:\TempHTML2.htm"
Set FSO = CreateObject("Scripting.FilesystemObject")
On Error Resume Next
Set MyRange = ActiveSheet.Range("A1:F" & NoF)
If MyRange Is Nothing Then Exit Sub
ActiveWorkbook.PublishObjects.Add _
(4, TempFile1, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
Set MyRange = ActiveSheet.Range("G1")
ActiveWorkbook.PublishObjects.Add _
(4, TempFile2, 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)
With OutlookMsg
.HTMLBody = BodyText1.ReadAll & BodyText2.ReadAll
.Subject = Range("A2").Text & " " & Range("U1").Text
.To = ""
.CC = ""
.Display
End With
Kill TempFile1
Kill TempFile2
Set BodyText2 = Nothing
Set BodyText1 = Nothing
Set OutlookMsg = Nothing
Set OutlookApp = Nothing
Set MyRange = Nothing
Set FSO = Nothing
End Sub
Arkadaşlar benim bir sorunum vardı ve bu sorunu bir türlü çözemedim. Eski başlık altından devam edecektim ama onuda bulamadığım için tekrar başlık açmak zorunda kaldım kusura bakmayın.
Ben bir çalışma kitabında aktif sheet içerisinde yer alan tabloyu mailin içine aktarmak istiyorum. Ancak tablonun mesela "G1" sütununda yazılan açıklamayıda hemen altına yazdırmasını istiyorum. Sheeti dosya olarak göndermek bir çözüm ama iş görmediğinden direkt mailin içerisine yazdırılması gerekmekte. Bu arada mailin içerisine aktarılan tablo ve açıklama sola yanışık vaziyette olması gerekiyor.
Aşağıdaki kod bir önceki çalışmada yapılan koddur. Ancak bu kodla maalesef tabloyu mailin içine yazdırmayı başardım (ancak sola yanaşık değil ortalayarak yazdı) ancak bir türlü "G1" hücresine girilen açıklamayı tablonun altına yazdıramadım. Başka bilgisayarda çalışıyormuş ancak nedense benimkinde ne yaptımsa çalışmadı. Ben C sürücüsünü kullanamıyorum. (C sürücüsü kısıtlaması var) Belki ondan oluyor dedim ama belki sizlerin yazacağı başka bir kodla bu sorunu çözmem mümkün olur diye düşündüm.
Aşağıda hazırlanan kodu veriyorum. Bu arada tablonun "A1:F65536" aralığında olduğu varsayılmış ve açıklamanında "G1" de olduğu varsayılmıştır.
Ãimdiden teşekkürler
Sub EmailSheet3()
Dim OutlookApp As Object, OutlookMsg As Object
Dim FSO As Object
Dim BodyText1 As Object, BodyText2 As Object
Dim MyRange As Range
Dim TempFile1 As String, TempFile2 As String
Dim NoF As Long
NoF = Range("F65536").Cells.End(xlUp).Row
TempFile1 = "E:\TempHTML1.htm"
TempFile2 = "E:\TempHTML2.htm"
Set FSO = CreateObject("Scripting.FilesystemObject")
On Error Resume Next
Set MyRange = ActiveSheet.Range("A1:F" & NoF)
If MyRange Is Nothing Then Exit Sub
ActiveWorkbook.PublishObjects.Add _
(4, TempFile1, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
Set MyRange = ActiveSheet.Range("G1")
ActiveWorkbook.PublishObjects.Add _
(4, TempFile2, 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)
With OutlookMsg
.HTMLBody = BodyText1.ReadAll & BodyText2.ReadAll
.Subject = Range("A2").Text & " " & Range("U1").Text
.To = ""
.CC = ""
.Display
End With
Kill TempFile1
Kill TempFile2
Set BodyText2 = Nothing
Set BodyText1 = Nothing
Set OutlookMsg = Nothing
Set OutlookApp = Nothing
Set MyRange = Nothing
Set FSO = Nothing
End Sub