e-postaya aktif sayfayı gönder

[omeryılmaz]

Saygı değer Hocalarım dostlarım...
Hasta müracaatına göre ilişikteki formu defalarca Bakanlığımıza ait e-postaya göndermemiz gerkmektedir. Ancak ben olmadığım zamanlarda arkadaşlar Sağlık Bakanlığına ait e-posta sayfasını kullanamadıklarından, direk olarak butonla nasıl bu sayfayı e-postaya aktarabiliriz....
e postaya gönder butouna basınca başka işlem yapmadan veri ilgili e postaya aktarılmalı..
Bilgisayardan anlamayan arkadaş çok.. Onlarda basit bir şekilde bu işlemi gerçekleştirebilmeli...
Bir haftadır uğraştım bütün ilgili sayfaları inceledim anlamadım....

Yardımlarınız için şimdiden şükranlarımı sunuyorum..

 

[Kemal Demir]

Merhaba,

http://www.excel.web.tr/f48/aktif-sayfay-e-mail-ile-gonder-t43902/sayfa2.html

Yukarıdaki lınkı ınceleyiniz.

Haluk Bey'in kodu,

Vba editorunde Outlook referansını ekleyiniz.

'******************************************************
'* Sadece Aktif sayfayı MS Outlook ile yollamak için  *
'* yapılmış bir çalışmadır                            *
'* Micosoft Outlook X.0 referansı eklenmelidir !      *
'* Burası Excel vadisi ...                            *
'* Raider ®                                           *
'* Subat 2005                                         *
'******************************************************

Sub SendShByEmail()
    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:\" & 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
        .To = "falan@filan.com"
        .Subject = "Deneme"
        .Body = "Bu e-mail deneme amacıyla gönderilmiştir."
        .Attachments.Add WbName
        .Save
        .Send
    End With
    
    Set NewMail = Nothing
    Set OutApp = Nothing
    Set VBComp = Nothing
    Kill WbName
End Sub

 

[omeryılmaz]

epostaya göndermiyor

Arkadaşlar Haluk Bey'in kodlarını ekledim. değişik diğer çalışmalarınıda denedim, neden hata veriyor. Öncelikle Haluk bey olmak üzere emeği geçen ve ilgilenen arkadaşlara şükranlarımı sunuyorum...

Dim OutApp As Outlook.Application
Dim NewMail As Outlook.MailItem
Dim ShName As String, WbName As String

başlayarak hata veriyor.. Dosya ektedir..... Deneme amaçlı "omerylzom@hotmail.com" adresine gönder diyebilirsiniz....

 

[Kemal Demir]

Merhaba,

2 dosyayıda inceleyiniz.

 

[omeryılmaz]

epostaya göndermiyor

Her ikisindede bende

ThisWorkbook.SaveCopyAs WbName hata vermektedir..neden? Makroları etkinleştiriyorum yine olmuyor....saygılar

 

[Kemal Demir]

Ömer bey,

Nedeni ni bende anlamadım.Ama aşagıdaki kodu sildiğiniz takdirde sorun kalkacaktır dıye dusunuyorum.Kodu kaldırarak size mail yolladım.

  Dim bool As Boolean
   strRefPath = "C:\Program Files\Microsoft Office\OFFICE11\msoutl.olb" 'ADO
    bool = False
   For Each ref In ThisWorkbook.VBProject.References
        If ref.fullPath = strRefPath Then bool = True
   Next

 

[omeryılmaz]

Kemal Bey ilginiz için şükranlarımı sunuyorum ancak;
Her iki türlüde olmadı.
Öncelikle "ThisWorkbook.SaveCopyAs WbName" hata vermektedir....


Devamlı bu dosyanın gönderilecek adresi olan
corlu.7nso@sağlik.gov.tr " 'Microsoft Outlook Web Access

 

[Kemal Demir]

Ömer Bey,

Aşağıdaki kod'u boş bir excel sayfasının modulune yapıstırıp test edermisiniz.
Vb referanslarında "Microsoft Outlook 11.0 yada 12.0" kısmını seçerek denermisiniz.

Haluk Bey'e ait olan kod'u kullanınız.

Sub SendShByEmail()
    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:\" & 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
        .To = "omerylzom@hotmail.com"
        .Subject = "Deneme"
        .Body = "Bu e-mail deneme amacıyla gönderilmiştir."
        .Attachments.Add WbName
        .Save
        .Send
    End With
    
    Set NewMail = Nothing
    Set OutApp = Nothing
    Set VBComp = Nothing
    Kill WbName
End Sub

 

[omeryılmaz]

Kemal Bey in Deneme amaçlı "corlu.7nso@sağlik.gov.tr " ye gönderdiği dosya yerine ulaşmış. Niçin aynı dosya benim bilgisayarlarımda gönder dediğimde ....
"ThisWorkbook.SaveCopyAs WbName"
hata vermektedir....

 

[turkuaz81]

Alternatif maille bilgi gönderme yöntemi

Şayetki dosyayı form olarak göndermeniz şart değilse ,ekte yolladığım dosya : tanımlı alanı .jpeg olarak önce C: ye kaydediyor ve ek dosya olarak maille gönderiyor.
Göndereceği mailler L57 ve L58 de.

Çalışması için Sizde Outlook kurulu olmalı !