Hücre Dolu ise Otomatik Mail Gönder

M

MiRaBiLiS

Katılım
22 Ağustos 2014
Mesajlar
45
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba arkadaşlar. forumda aradım ancak bu tarz bir konu bulamadım hep bir butona göre mail gönderimi yapabiliyoruz. benim ricam ise,

a3 hücresi dolu ise belirlenen adreslere a3 hücresini kopyalayıp mail olarak göndersin.

mevcut bir mail gönderme makrom var zaten o makronun içine bunu da gömerek çalıştıracağım. ikisi bir arada olduğunda karışmaz umarım. mevcut makrom aşağıdadır.

yardımcı olursanız memnun olurum arkadaşlar.

Kod: 
Sub sendMail24()
ActiveSheet.PageSetup.PrintArea = "GECE"
ActiveSheet.PrintOut
'Shell "yedekle.bat"
ActiveSheet.Unprotect 123
    Range("T149:AE165").Select
    
    Dim TempFilePath As String
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xHTMLBody As String
    Dim xRg As Range
    Dim xSheet As Worksheet
    Dim xAcSheet As Worksheet
    Dim xFileName As String
    Dim xSrc As String
    On Error Resume Next
    TempFilePath = Environ$("temp") & "\RangePic\"
    If Len(VBA.Dir(TempFilePath, vbDirectory)) = False Then
      VBA.MkDir TempFilePath
    End If
    Set xAcSheet = Application.ActiveSheet
    For Each xSheet In Application.Worksheets
        xSheet.Activate
        Set xRg = xSheet.Application.Selection
        If xRg.Cells.Count > 1 Then
            Call createJpg(xSheet.Name, xRg.Address, "DashboardFile" & VBA.Trim(VBA.Str(xSheet.Index)))
        End If
    Next
    xAcSheet.Activate
    With Application
        .Calculation = xlAutomatic
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set xOutApp = CreateObject("outlook.application")
    Set xOutMail = xOutApp.CreateItem(olMailItem)
    xSrc = ""
    xFileName = Dir(TempFilePath & "*.*")
    Do While xFileName <> ""
        xSrc = xSrc + VBA.vbCrLf + "<img src='cid:" + xFileName + "'><br>"
        xFileName = Dir
        If xFileName = "" Then Exit Do
    Loop
    xHTMLBody = "<span LANG=tr>" _
                & "<p class=style2><span LANG=TR><font FACE=verdana SIZE=3>" _
                & "Sayın İlgililer;<br> " _
                & "24/08 Vardiyasında Depomuza Giren, Depomuzdan Sevkedilen, Kalan Depo miktarları ve Günlük özet tablosu aşağıda yer almaktadır.<br>" _
                & "<br> " _
                & "<br> " _
                & "<br> " _
                & xSrc _
                & "<br>Bilgilerinize.</font></span>"
    With xOutMail
        .Subject = ""
        .HTMLBody = xHTMLBody
        xFileName = Dir(TempFilePath & "*.*")
        Do While xFileName <> ""
            .Attachments.Add TempFilePath & xFileName, olByValue
            xFileName = Dir
        If xFileName = "" Then Exit Do
        Loop
        .To = "mail@mail.com"
        .CC = "mail@mail.com"
        .Subject = "24/08 Vardiya Sonu ve Günlük Hareket Raporu"
        '.Send
       .Display
        

    End With
    If VBA.Dir(TempFilePath & "*.*") <> "" Then
        VBA.Kill TempFilePath & "*.*"
    ActiveWindow.ScrollColumn = 1
    Range("A125").Select
    End If
    ActiveSheet.Protect 123
End Sub
Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
    Dim xRgPic As Range
    ThisWorkbook.Activate
    Worksheets(SheetName).Activate
    Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
    xRgPic.CopyPicture
   ' With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
     '   .Activate
    '   .Chart.Paste
      '  .Chart.Export Environ$("temp") & "\RangePic\" & nameFile & ".jpg", "JPG"
    ' End With
    Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub
 
D

DoğanD

Altın Üye
Katılım
22 Eylül 2023
Mesajlar
413
Excel Vers. ve Dili
Office 365 TR
Altın Üyelik Bitiş Tarihi
05-10-2028
Merhaba,

Peki hücre nasıl doluyor? Formül var ise, maili gönderdikten sonra değişimini mi takip edecek yoksa mevcut içeriği boşaltacak şekilde mi bir kurgu var kafanızda? Sonuç olarak bir tetikleyiciye ihtiyaç var ve bu Worksheet_Change yada _Calculate olayı ile gelecek. Formül ile doluyorsa hücre Calculate olayında hücre değeri değişmese bile her formül hesaplamasında mail spamlayacağı anlamına geliyor.
 
M

MiRaBiLiS

Katılım
22 Ağustos 2014
Mesajlar
45
Excel Vers. ve Dili
Ofis 365 Türkçe
DoğanD' Alıntı:
Merhaba,

Peki hücre nasıl doluyor? Formül var ise, maili gönderdikten sonra değişimini mi takip edecek yoksa mevcut içeriği boşaltacak şekilde mi bir kurgu var kafanızda? Sonuç olarak bir tetikleyiciye ihtiyaç var ve bu Worksheet_Change yada _Calculate olayı ile gelecek. Formül ile doluyorsa hücre Calculate olayında hücre değeri değişmese bile her formül hesaplamasında mail spamlayacağı anlamına geliyor.
Genişletmek için tıkla ...
merhaba,

Kod: 
=EĞER(AH148<2;"DİKKAT! Sayın 8/16 vardiyasında görevli vardiya amiri; lütfen vardiyanızda önümüzdeki sevkiyatlarda kullanılmak üzere 4 palet 44lü Mauri 1/2 kg. üretim planınıza almanızı rica ederim. ";" ")
ilgili hücrede bu değer var. yani bir hücrenin değeri (AH148) 2den küçük ise o hücrede bir metin yazacak. o metinde mail olarak gönderilecek. bunu aslında kod olarakta yaptırabiliriz. ama hücre değerini sürekli kontrol etmeyecek. üstte verdiğim makronun içerisinde yazacağım ve vardiya sonunda rapor çıkartmak için butona basacaklar ve o zaman kontrol edecek, ve eşleşme tutuyorsa o zaman mail gönderecek.

makro içerisinde makro olur mu bilemediğim için aklıma gelen çözümü yazdım.

dosyanın işleyişi şu şekilde ;

vardiya üretim ve sevkiyat miktarlarını giriyor. yukarıdaki verdiğim kodda da bu miktarlar belirli alanlarda yazılı oluyor o miktarları seçip resim olarak kopyalıyor ve belirli kişilere mail olarak vardiya sonu raporu olarak mail gönderiyor.

benim amacım bu hazırda vardiya sonlarında çalışan makronun içine bunu da dahil etmek. tek buton ile bu kontrolü de sağlatıp gerekiyorsa mailin gönderilmesini sağlamak.
 
D

DoğanD

Altın Üye
Katılım
22 Eylül 2023
Mesajlar
413
Excel Vers. ve Dili
Office 365 TR
Altın Üyelik Bitiş Tarihi
05-10-2028
Aynı mailde body kısmına eklencekse aşağıdaki ufak ekleme ile sorununuzu çözebilirsiniz. Değilse, aynı sub içinde if range("A3") <> "" then call gonder kodunu ekleyip, aşağıdaki kod bloku ile ayrıca mail gönderebilirsiniz.

Ayrı Mail:
Kod: 
Sub Gonder()
Dim Makro As Object
Dim Mail As Object
Set Makro = CreateObject("Outlook.Application")
Set Mail = Makro.CreateItem(0)
On Error Resume Next
With Mail
.To = "hedef@hedefadresi.com.tr"
.CC = "bilgi"
.BCC = "gizli bilgi"
.Subject = "Mail Konusu"
.Body = range("A3").value
.Attachments.Add 'varsa ek'
.display 'yada .send'
End With
On Error GoTo 0
Set Mail = Nothing
Set Makro = Nothing
End Sub

Mevcut Mailin içine:
uyari=range("A3").value
xHTMLBody = "<span LANG=tr>" _
& "<p class=style2><span LANG=TR><font FACE=verdana SIZE=3>" _
& "Sayın İlgililer;<br> " _
& "24/08 Vardiyasında Depomuza Giren, Depomuzdan Sevkedilen, Kalan Depo miktarları ve Günlük özet tablosu aşağıda yer almaktadır.<br>" _
& "<br> " _
& "<br> " _
& uyari _
& "<br> " _
& xSrc _
& "<br>Bilgilerinize.</font></span>"
 
M

MiRaBiLiS

Katılım
22 Ağustos 2014
Mesajlar
45
Excel Vers. ve Dili
Ofis 365 Türkçe
DoğanD' Alıntı:
Aynı mailde body kısmına eklencekse aşağıdaki ufak ekleme ile sorununuzu çözebilirsiniz. Değilse, aynı sub içinde if range("A3") <> "" then call gonder kodunu ekleyip, aşağıdaki kod bloku ile ayrıca mail gönderebilirsiniz.

Ayrı Mail:
Kod: 
Sub Gonder()
Dim Makro As Object
Dim Mail As Object
Set Makro = CreateObject("Outlook.Application")
Set Mail = Makro.CreateItem(0)
On Error Resume Next
With Mail
.To = "hedef@hedefadresi.com.tr"
.CC = "bilgi"
.BCC = "gizli bilgi"
.Subject = "Mail Konusu"
.Body = range("A3").value
.Attachments.Add 'varsa ek'
.display 'yada .send'
End With
On Error GoTo 0
Set Mail = Nothing
Set Makro = Nothing
End Sub

Mevcut Mailin içine:
uyari=range("A3").value
xHTMLBody = "<span LANG=tr>" _
& "<p class=style2><span LANG=TR><font FACE=verdana SIZE=3>" _
& "Sayın İlgililer;<br> " _
& "24/08 Vardiyasında Depomuza Giren, Depomuzdan Sevkedilen, Kalan Depo miktarları ve Günlük özet tablosu aşağıda yer almaktadır.<br>" _
& "<br> " _
& "<br> " _
& uyari _
& "<br> " _
& xSrc _
& "<br>Bilgilerinize.</font></span>"
Genişletmek için tıkla ...
Gerçekten çok teşekkür ederim istediğim gibi gayet basit ve kolay bir şekilde gerçekleştirdi işlemi. sağolun.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst