Hücreye girilen değere göre çalışan mail macrosu.

[xwolkyx]

Arkadaşlar ektede belirttiğim üzere istenen koşul sağlandığında tanımlanan adrese mail atabilecek bir macro varmı?
Şimdiden teşekkürler

 

[Korhan Ayhan]

Selamlar,

Mail atmak için hangi sistemi kullanmayı düşünüyorsunuz?

 

[xwolkyx]

Mevcut Outlook 2007 hesabımı.

 

[Korhan Ayhan]

Selamlar,

Koşul sağlandığında dosyanın tamamı mı mail atılacak?

 

[Korhan Ayhan]

Selamlar,

Sanırım yoğunsunuz. Geri dönüş yapmadınız. Belirttiğiniz şartlar gerçekleştiğinde aşağıdaki kod ile sayfanın bir kopyası oluşur ve otomatik olarak mail gövdesine eklenir. Size sadece gönder butonuna tıklamak kalıyor. Eğer direk göndersin derseniz kod içinde kırmızı renkle belirttiğim satırın başındaki tek tırnak işaretini silmeniz yeterlidir.

Kod içinde geçen dosya adı yolunu kendinize göre değiştirmeyi unutmayın.


Sayfanın kod bölümüne uygulayın.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Outlook_Uygulaması As Object
    Dim Outlook_Mail As Object
    Dim Dosya_Adı As Variant
    Dim Sayfa_Kodu As Object
    
    If Intersect(Target, [C3:C8]) Is Nothing Then Exit Sub
    If WorksheetFunction.CountA([C3:C8]) = 6 Then
 
    Dosya_Adı = "C:\Users\Korhan\Documents\Deneme.xls"
 
    ActiveSheet.Copy
    
    Set Sayfa_Kodu = ActiveWorkbook.VBProject.VBComponents(ActiveSheet.Name).CodeModule
    Sayfa_Kodu.DeleteLines 1, Sayfa_Kodu.CountOfLines
    
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=Dosya_Adı
    Application.DisplayAlerts = True
 
    Set Outlook_Uygulaması = CreateObject("Outlook.Application")
    Outlook_Uygulaması.Session.Logon
    Set Outlook_Mail = Outlook_Uygulaması.CreateItem(0)
 
    With Outlook_Mail
        .To = "deneme.denemegmail.com"
        .Cc = ""
        .Bcc = ""
        .Subject = "Bu bir deneme mailidir."
        .BodyFormat = 2
        .Attachments.Add Dosya_Adı
        .Display
        [COLOR=red]'.Send[/COLOR]
    End With
 
    Set Outlook_Mail = Nothing
    Set Outlook_Uygulaması = Nothing
    
    End If
End Sub

 

[SER973]

Lotus Notes'te Nasıl olur...

Korhan Bey

Yazmış olduğunuz KOD Outlookta çok güzel çalışıyor.. Ancak Ben Lotus Notes Kullanıyorum.. Bu Kodu Lotus Notese nasıl uyarlayabiliriz. Yardımlarınızı rica ediyorum..Teşekkürler