Belirli bir sayfayı formülsüz olarak yeni bir çalışma kitabı ile kayıt etme

[ugray57]

Merhaba,

3-4 sayfadan oluşan bir çalışma kitabında ilk sayfa ana verileri girdiğim sayfa ve buradaki buton yardımı ile mail göndermek istiyorum. Şuan formül çalışıyor ancak ana çalışma kitabının ilgili sayfasındaki formüller ile birlikte mail atabiliyorum. Sayfanın biçimi bozulmadan formülsüz nasıl gönderebilirim. Şimdiden teşekkür ederim.

Sub YuvarlatılmışDikdörtgen2_Tıkla()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Dim evn As Object
Dim x As String
x = "\\bsh.corp.bshg.com\fredirect\TR\IST\AyU\Desktop\" & Cells(6, "b") & " " & Cells(7, "b") & "-****" & ".xlsx"
Set evn = CreateObject("scripting.filesystemobject")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
If ActiveSheet.Name <> "**** YARATMA FORMU" Then
With OutMail
.To = Cells(5, "G")
.CC = Cells(5, "H")
.BCC = ""
.Subject = Cells(6, "b") & " " & Cells(7, "b") & " / " & "Yeni Açılış Hk."
.Body = "Merhaba" & " " & Cells(5, "f") & "," & Chr(13) & Chr(13) & _
"Yeni mağaza açılışı ile ilgili form ekteki gibidir. Kullanıcı adı ve şifre bilgilerinin formda yer alan yekili mail adresine gönderimini rica ederim." & Chr(13) & Chr(13) & _
"Saygılarımla," & Chr(13) & Chr(13) & _
"Uğur ***" & Chr(13) & Chr(13) & _
"******** Bölge" & Chr(13) & _
"***********" & Chr(13) & Chr(13) & _
"Tel. : +90 216 *******" & Chr(13) & _
"Mobile : +90 549 ********" & Chr(13) & _
"Fax : +90 216 **********9 " & Chr(13) & _
"E-Mail : ugur.***********" & Chr(13) & Chr(13)

Worksheets("DİVA YARATMA FORMU").Copy
With ActiveWorkbook
.SaveAs Filename:=x, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close SaveChanges:=False
End With
.Attachments.Add x
.Display
End With

End If

End Sub

 

[Muzaffer Ali]

Merhaba.

Aşağıdaki gibi yapabilirsiniz.

Sub YuvarlatılmışDikdörtgen2_Tıkla()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Dim evn As Object
Dim x As String
x = "\\bsh.corp.bshg.com\fredirect\TR\IST\AyU\Desktop\" & Cells(6, "b") & " " & Cells(7, "b") & "-****" & ".xlsx"
Set evn = CreateObject("scripting.filesystemobject")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
If ActiveSheet.Name <> "**** YARATMA FORMU" Then
With OutMail
.To = Cells(5, "G")
.CC = Cells(5, "H")
.BCC = ""
.Subject = Cells(6, "b") & " " & Cells(7, "b") & " / " & "Yeni Açılış Hk."
.Body = "Merhaba" & " " & Cells(5, "f") & "," & Chr(13) & Chr(13) & _
"Yeni mağaza açılışı ile ilgili form ekteki gibidir. Kullanıcı adı ve şifre bilgilerinin formda yer alan yekili mail adresine gönderimini rica ederim." & Chr(13) & Chr(13) & _
"Saygılarımla," & Chr(13) & Chr(13) & _
"Uğur ***" & Chr(13) & Chr(13) & _
"******** Bölge" & Chr(13) & _
"***********" & Chr(13) & Chr(13) & _
"Tel. : +90 216 *******" & Chr(13) & _
"Mobile : +90 549 ********" & Chr(13) & _
"Fax : +90 216 **********9 " & Chr(13) & _
"E-Mail : ugur.***********" & Chr(13) & Chr(13)

Worksheets("DİVA YARATMA FORMU").Copy
    
    Cells.Copy
    Cells.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
With ActiveWorkbook
.SaveAs Filename:=x, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close SaveChanges:=False
End With
.Attachments.Add x
.Display
End With