Aktif Sayfanın kopyasını mail olarak gönder..

[omeryılmaz]

Saygı değer Hocalarım
Sizlerin desteği ile Sağlık Ocağımıza hazırlamış olduğum, UserFormlu dökümanda Aktif sayfayı E Maile gönder dediğimde Aktif sayfa ile birlikte Moduller ve ThisWorkbook ta kayıtlı

Private Sub Workbook_Open()
On Error Resume Next
Application.Visible = False
UserForm2.Show
UserForm2.MultiPage1.Value = 0
tkrm.SetFocus
End Sub

koduda gittiği için karşı tarafta yine User ekranlı benim formum çıkmaktadır.

Benim isteğim Karşı tarafta sadece aktif sayfadaki UserFormla doldurulan Evrakın (Sayfanın) gitmesi....


Private Sub CommandButton43_Click()
Worksheets("TALASEMİ").Select
Dim bool As Boolean
strRefPath = "C:\Program Files\Microsoft Office\OFFICE12\msoutl.olb" 'ADO
bool = False
For Each ref In ThisWorkbook.VBProject.References
If ref.fullPath = strRefPath Then bool = True
Next
' 'MsgBox "kontroller tamamlandı.": Exit Sub
'<<<<<<<<<<<<<<<<<<<<<<<İŞLEMLER>>>>>>>>>>>>>>>>>> >>>>>>>>>>>
Dim OutApp As Outlook.Application
Dim NewMail As Outlook.MailItem
Dim ShName As String, WbName As String
Dim i As Integer
Dim ModX As Object, VBComp As Object

ShName = ActiveSheet.Name
'WbName = "C:\Users\CASPER\Desktop" & ShName & ".xls"
WbName = "C:\" & ShName & ".xls"
ThisWorkbook.SaveCopyAs WbName

Application.DisplayAlerts = False
Workbooks.Open WbName

For i = Sheets.Count To 1 Step -1
If ActiveWorkbook.Sheets(i).Name <> ShName Then Sheets(i).Delete
Next

On Error Resume Next
For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBComp = ActiveWorkbook.VBProject.VBComponents(ModX.Name)
ActiveWorkbook.VBProject.VBComponents.Remove VBComp
Next
On Error GoTo 0
Application.DisplayAlerts = True

ActiveWorkbook.Close SaveChanges:=True

Set OutApp = New Outlook.Application
Set NewMail = CreateItem(olMailItem)

With NewMail
adr = "omerylzom@gmail.com"
.To = adr
.Subject = "Çorlu 7 No'lu Sağlık Ocağı Tabipliği"
.Body = "Bu e-mail eki Hemoglobinopati Kontrol Programı kapsamında, corlu.7nso Tabipliğince alınan kanların takibi ve e posta ile, ilgili Kuruma otomotik aktarılması için, hazırlanmış programdır. EKİ : 'Talasemi Tarama istek formudur."
.Attachments.Add WbName
.Save
.Send
End With

Set NewMail = Nothing
Set OutApp = Nothing
Set VBComp = Nothing
Kill WbName
MsgBox "Bu Mail ile " & adr & " adresine " & ShName & " sayfası gönderildi."
End Sub


Şimdiden yardımlarınız ve ilginiz için şükranlarımı sunuyorum... Saygılar

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu kullanabilirsiniz. Koddaki kırmızı renkli bölümleri kendinize göre düzeltiniz.

Sub AKTİF_SAYFAYI_MAİL_AT()
    Dim Outlook_Uygulaması As Outlook.Application
    Dim Yeni_Mail As Outlook.MailItem
    Dim Dosya_Adı As String, Mail_Dosyası As String
 
    Application.ScreenUpdating = False
        ActiveSheet.Copy
        Mail_Dosyası = "[COLOR=red]C:\Documents and Settings\Admin\Desktop[/COLOR]\Talasemi İstek Formu" & ".xls"
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:= Mail_Dosyası
        Application.DisplayAlerts = True
        ActiveWorkbook.Close
    Application.ScreenUpdating = True
 
    Set Outlook_Uygulaması = New Outlook.Application
    Set Yeni_Mail = CreateItem(olMailItem)
    With Yeni_Mail
    .To = ""
    .Subject = ""
    .Body = "Bu e-maili aldıysanız sorun yok demektir."
    .Attachments.Add Mail_Dosyası
    '.Display ' Maili ekranda görüntüler.
    .Send ' Maili direk gönderir.
    End With
    Set Outlook_Uygulaması = Nothing
    Set Yeni_Mail = Nothing
    Kill Mail_Dosyası
End Sub

 

[omeryılmaz]

Hocam
Yukarıdaki kod işimi gördü ellerinize sağlık ancak;
E mail olarak gönderilen sayfa "C:\Users\CASPER 'e
C klasörüne Desktop olarak devamlı kaydedilmektedir.
Günlük olarak hasta müracaatına bağlı olarak çok sayfa gönderileceği için bu kopya yedeğini nasıl silebiliriz.
Ayrıca
Gönderilen sayfaya " Talasemi İstek Formu" adı verilebilirmi?

 

[Korhan Ayhan]

Selamlar,

Üstteki mesajımdaki kodu güncelledim. İncelermisiniz.