Merhabalar. Buradaki konulardan ve yardımlardan faydalanarak oluşturduğum (düzenlediğim) mail kodları excel 2007 üzerinde sıkıntı oluşturuyor. Aslında tek sıkıntı oluşan nokta çalışma sayfasının htmlbody olarak eklenmemesi. Yada mail gönderildiğinde ilgili sayfanın eklenmemiş olması. (Ek olarak değil, maildeki body kısmına sanki kopyala yapıştır denilmiş şekilde eklenmemesi.) Resim ekleyebilirsem sanırım daha açıklayıcı olacak gibi. En kısa sürede eklemeye çalışacağım.
Mevcut kodlarım :
Public Function SheetToHTML(sh As Worksheet)
Dim TempFile As String
Dim Nwb As Workbook
Dim myshape As Shape
Dim fso As Object
Dim ts As Object
sh.Copy
Set Nwb = ActiveWorkbook
For Each myshape In Nwb.Sheets(1).Shapes
myshape.Delete
Next
TempFile = Environ$("temp") & "/" & _
Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
Nwb.SaveAs TempFile, xlHtml
Nwb.Close False
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
SheetToHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Set Nwb = Nothing
Kill TempFile
End Function
Sub Mail_Hazirlik()
Set M1 = Workbooks("Is_Emri_Acma.xls").Worksheets("FORM")
Set M2 = Workbooks("Is_Emri_Acma.xls").Worksheets("MAIL")
M1.Range("L4:M4").Value = ""
M1.Range("A3:N44").Select
Selection.Copy
M2.Visible = True
M2.Activate
M2.Range("A3").Select
ActiveSheet.Paste
M2.Range("A3").Select
M1.Activate
M1.Range("A3").Select
Application.CutCopyMode = False
M1.Range("A3").Select
M2.Activate
End Sub
Sub Mail_ActiveSheet_Body()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = Worksheets("FORM").Range("Q17")
.CC = ""
.BCC = ""
.Subject = Worksheets("FORM").Range("B3").Value & " Numaralı İş Emri Açılmıştır"
.HTMLBody = SheetToHTML(ActiveSheet)
.Send 'or use .Display
End With
Application.ScreenUpdating = False
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
İlginize teşekkürler.
Mevcut kodlarım :
Public Function SheetToHTML(sh As Worksheet)
Dim TempFile As String
Dim Nwb As Workbook
Dim myshape As Shape
Dim fso As Object
Dim ts As Object
sh.Copy
Set Nwb = ActiveWorkbook
For Each myshape In Nwb.Sheets(1).Shapes
myshape.Delete
Next
TempFile = Environ$("temp") & "/" & _
Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
Nwb.SaveAs TempFile, xlHtml
Nwb.Close False
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
SheetToHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Set Nwb = Nothing
Kill TempFile
End Function
Sub Mail_Hazirlik()
Set M1 = Workbooks("Is_Emri_Acma.xls").Worksheets("FORM")
Set M2 = Workbooks("Is_Emri_Acma.xls").Worksheets("MAIL")
M1.Range("L4:M4").Value = ""
M1.Range("A3:N44").Select
Selection.Copy
M2.Visible = True
M2.Activate
M2.Range("A3").Select
ActiveSheet.Paste
M2.Range("A3").Select
M1.Activate
M1.Range("A3").Select
Application.CutCopyMode = False
M1.Range("A3").Select
M2.Activate
End Sub
Sub Mail_ActiveSheet_Body()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = Worksheets("FORM").Range("Q17")
.CC = ""
.BCC = ""
.Subject = Worksheets("FORM").Range("B3").Value & " Numaralı İş Emri Açılmıştır"
.HTMLBody = SheetToHTML(ActiveSheet)
.Send 'or use .Display
End With
Application.ScreenUpdating = False
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
İlginize teşekkürler.
