Soru Makro ile hem çıktı hem de Mail Gönderme

mc_exrem · 7 Nisan 2020

Merhabalar

Çalışma dosyamın KASA DEFTERİ sayfasında BuGünüYazdır butonu ile çıktı alıyorum. belirtilen zamanda degil de Çıktı için HER tıkladığımda mail göndermesini de istiyorum. @turist hocamın paylaştığı Bu kod işimi görür mü ya da düzenleyebilir misiniz. Teşekkür eder saygılar sunar Sıhhatli huzurlu günler dilerim.

Sub Aut

pen()
Application.OnTime TimeValue("12:18:00"), "MailGonder"
End Sub

Sub MailGonder()
Dim OutApp As Object, Outmail As Object
Set OutApp = CreateObject("Outlook.Application")
Set Outmail = OutApp.CreateItem(0)
Outmail.BodyFormat = 2
With Outmail
.To = "genceller@hotmail.com.tr"
.CC = ""
.Subject = "KONTR0L M€RK3Z1"
.Attachments.Add D:\Şirket Evrakları\Kontrol Merkezi.xlsm
.Display
.Send 'Göndermek için .send den önceki ' tek tırnak işaretini kaldırın
End With
Set Outmail = Nothing: Set OutApp = Nothing
End Sub

u.L.a.s · 8 Nisan 2020

çıktı için bastığın butona atadığın makronun sonuna
Call MailGonder
kodunu eklemen yeterli. böylelikle çıktı için butona bastığında çıktını alacaksın ve ardından yazdırdığın bu alanı da mail olarak göndermiş olacaksın

hamitcan · 8 Nisan 2020

BeforePrint olayını kullanabilirsiniz. Çalışma kitabının ThisWorkBook kısmına ekleyin.

Kod:

Private Sub Workbook_BeforePrint(Cancel As Boolean)
'... Kodlarınız
End Sub

mc_exrem · 8 Nisan 2020

hamitcan' Alıntı:
BeforePrint olayını kullanabilirsiniz. Çalışma kitabının ThisWorkBook kısmına ekleyin.

Kod:

Private Sub Workbook_BeforePrint(Cancel As Boolean) '... Kodlarınız End Sub

Kodlara hakim olmadığım için sayfamda birçok kod olduğu için affınıza sığınarak eklediğim dosyaya eklemeniz rica olunur.

hamitcan · 9 Nisan 2020

Öncelikle belirteyim, kodlara hakim olmadan böyle bir yapı oluşturduğunuz için sizi tebrike etmek lazım.
BeforePrint olayını kullanmadan sizin daha önce belirlediğiniz SurYaz kodu sonuna MailGonder başlığını ekledim. Tabii ki MailGonder kodunu module ekleminiz gerekmektedir.

Kod:

Sub SuzYaz()
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Kson = Evaluate("=Kson")
bugun = CLng([F3])
adet = WorksheetFunction.CountIf(Range("F4:F" & Kson), bugun)
If adet = 0 Then
    MsgBox [F3] & " gününe ait kayıtlı veri yok.", vbCritical
    Range("$B$3:$F$3").AutoFilter Field:=5
    GoTo 10
Else
    Range("$B$3:$F$3").AutoFilter Field:=5, Criteria1:=">=" & CLng(bugun)
    ActiveSheet.PageSetup.PrintArea = "$B$1:$G$" & Kson
    ActiveSheet.PrintOut Copies:=1, ActivePrinter:="Ne00: üzerindeki P-3025 MFP KX", _
    Collate:=True, IgnorePrintAreas:=False
    Range("$B$3:$F$3").AutoFilter Field:=5
    MsgBox [F3] & " tarihine ait veriler yazıcıya gönderildi.", vbInformation
    MailGonder
End If
10:
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
End Sub

mc_exrem · 9 Nisan 2020

hamitcan' Alıntı:

Öncelikle belirteyim, kodlara hakim olmadan böyle bir yapı oluşturduğunuz için sizi tebrike etmek lazım.
BeforePrint olayını kullanmadan sizin daha önce belirlediğiniz SurYaz kodu sonuna MailGonder başlığını ekledim. Tabii ki MailGonder kodunu module ekleminiz gerekmektedir.

Kod:

Sub SuzYaz()
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Kson = Evaluate("=Kson")
bugun = CLng([F3])
adet = WorksheetFunction.CountIf(Range("F4:F" & Kson), bugun)
If adet = 0 Then
    MsgBox [F3] & " gününe ait kayıtlı veri yok.", vbCritical
    Range("$B$3:$F$3").AutoFilter Field:=5
    GoTo 10
Else
    Range("$B$3:$F$3").AutoFilter Field:=5, Criteria1:=">=" & CLng(bugun)
    ActiveSheet.PageSetup.PrintArea = "$B$1:$G$" & Kson
    ActiveSheet.PrintOut Copies:=1, ActivePrinter:="Ne00: üzerindeki P-3025 MFP KX", _
    Collate:=True, IgnorePrintAreas:=False
    Range("$B$3:$F$3").AutoFilter Field:=5
    MsgBox [F3] & " tarihine ait veriler yazıcıya gönderildi.", vbInformation
    MailGonder
End If
10:
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
End Sub

Teşekkür ederim. Pazartesi şirketten yazıcı ortamından deneyip gelişmeleri paylaşacağım.

mc_exrem · 16 Nisan 2020

kodu bu şekilde düzeltmeye çalıştım ama nerde hata yapıyorum. Ne yazıyor ne de mail gönderiyor?

Sub SuzYaz()
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Sub Aut

pen()
Application.OnTime TimeValue("12:18:00"), "MailGonder"
End Sub

Sub MailGonder()
Dim OutApp As Object, Outmail As Object
Set OutApp = CreateObject("Outlook.Application")
Set Outmail = OutApp.CreateItem(0)
Outmail.BodyFormat = 2
With Outmail
.To = "genceller@hotmail.com.tr"
.CC = ""
.Subject = "KONTR0L M€RK3Z1"
.Attachments.Add C:\Users\user\OneDrive\Masaüstü
.Display
.Send 'Göndermek için .send den önceki ' tek tırnak işaretini kaldırın
End With
Set Outmail = Nothing: Set OutApp = Nothing
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Kson = Evaluate("=Kson")
bugun = CLng([F3])
adet = WorksheetFunction.CountIf(Range("F4:F" & Kson), bugun)
If adet = 0 Then
MsgBox [F3] & " gününe ait kayıtlı veri yok.", vbCritical
Range("$B$3:$F$3").AutoFilter Field:=5
GoTo 10
Else
Range("$B$3:$F$3").AutoFilter Field:=5, Criteria1:=">=" & CLng(bugun)
ActiveSheet.PageSetup.PrintArea = "$B$1:$G$" & Kson
ActiveSheet.PrintOut Copies:=1, ActivePrinter:="Ne00: üzerindeki P-3025 MFP KX", _
Collate:=True, IgnorePrintAreas:=False
Range("$B$3:$F$3").AutoFilter Field:=5
MsgBox [F3] & " tarihine ait veriler yazıcıya gönderildi.", vbInformation
MailGonder
End If
10:
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
End Sub

hamitcan · 17 Nisan 2020

Siz işi biraz karıştırmışsınız. Kodları aşağıdaki gibi bir Module içine ekleyin. Auto _open prosedürünü de kaldırın.

Kod:

Sub MailGonder()
Dim OutApp As Object, Outmail As Object
Set OutApp = CreateObject("Outlook.Application")
Set Outmail = OutApp.CreateItem(0)
Outmail.BodyFormat = 2
With Outmail
.To = "genceller@hotmail.com.tr"
.CC = ""
.Subject = "KONTR0L M€RK3Z1"
.Attachments.Add D:\Şirket Evrakları\Kontrol Merkezi.xlsm
.Display
.Send 'Göndermek için .send den önceki ' tek tırnak işaretini kaldırın
End With
Set Outmail = Nothing: Set OutApp = Nothing
End Sub

Sub SuzYaz()
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Kson = Evaluate("=Kson")
bugun = CLng([F3])
adet = WorksheetFunction.CountIf(Range("F4:F" & Kson), bugun)
If adet = 0 Then
    MsgBox [F3] & " gününe ait kayıtlı veri yok.", vbCritical
    Range("$B$3:$F$3").AutoFilter Field:=5
    GoTo 10
Else
    Range("$B$3:$F$3").AutoFilter Field:=5, Criteria1:=">=" & CLng(bugun)
    ActiveSheet.PageSetup.PrintArea = "$B$1:$G$" & Kson
    ActiveSheet.PrintOut Copies:=1, ActivePrinter:="Ne00: üzerindeki P-3025 MFP KX", _
    Collate:=True, IgnorePrintAreas:=False
    Range("$B$3:$F$3").AutoFilter Field:=5
    MsgBox [F3] & " tarihine ait veriler yazıcıya gönderildi.", vbInformation
    MailGonder
End If
10:
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
End Sub

mc_exrem · 17 Nisan 2020

sayın @hamitcan ilginiz için teşekkür ederim

Böyle bi hata verdi belli olsun diye resim olarak gönderdim. Auto _open prosedürü nerden kapatılıyor. onu da bilmiyorum.
Yardımcı olabilir misiniz acaba?

hamitcan · 18 Nisan 2020

Auto _ Open prosedürüne gerek olmadığı için söyledim. Diğer konu; eklemek istediğiniz yolu çift tırnak içine almalısınız.
Örn: "D:\Şirket..." şeklinde.

mc_exrem · 18 Nisan 2020

bel

hamitcan' Alıntı:
Auto _ Open prosedürüne gerek olmadığı için söyledim. Diğer konu; eklemek istediğiniz yolu çift tırnak içine almalısınız.
Örn: "D:\Şirket..." şeklinde.

belirtebilir misiniz hangi satırlar? Yeterince Kod yoğunluğu var. gereksizse çalışma hızını yavaşlatmaması için kaldırmak istiyorum.

stirra_ej · 18 Nisan 2020

Hocam kırmızı yazılı yer var ya orda Add den sonra D nin başına tırnak koyacaksın birde xlsm nin en sonuna koyacaksın

mc_exrem · 19 Nisan 2020

stirra_ej' Alıntı:
Hocam kırmızı yazılı yer var ya orda Add den sonra D nin başına tırnak koyacaksın birde xlsm nin en sonuna koyacaksın

Eksik açıklama yazmışım galiba???? Auto_open prosedüründen bahsediyorum ama????

stirra_ej · 19 Nisan 2020

Sub Aut

pen()
Application.OnTime TimeValue("12:18:00"), "MailGonder"
End Sub

Üstteki koda gerek yok diyorlar...
Bu kod her açtığında mali gönderir bu kodu silersen sen butona bastığında hem çıktı alır hem amil gönderir

mc_exrem · 19 Nisan 2020

Kodun son hali olarak bu şekilde deneyeceğim. Doğrumudur acaba dostlar?

Sub MailGonder()
Dim OutApp As Object, Outmail As Object
Set OutApp = CreateObject("Outlook.Application")
Set Outmail = OutApp.CreateItem(0)
Outmail.BodyFormat = 2
With Outmail
.To = "genceller@hotmail.com.tr"
.CC = ""
.Subject = "KONTR0L M€RK3Z1"
.Attachments.Add “D:\Şirket Evrakları\Kontrol Merkezi.xlsm
.Display
.Send 'Göndermek için .send den önceki ' tek tırnak işaretini kaldırın
End With
Set Outmail = Nothing: Set OutApp = Nothing
End Sub

mc_exrem · 20 Nisan 2020

hamitcan' Alıntı:
Auto _ Open prosedürüne gerek olmadığı için söyledim. Diğer konu; eklemek istediğiniz yolu çift tırnak içine almalısınız.
Örn: "D:\Şirket..." şeklinde.

Resimdeki gibi bir hata aldım
-dosya adı doğru
-bulunduğu konum doğru

Dosyayı da ekledim.

Sub MailGonder()
Dim OutApp As Object, Outmail As Object
Set OutApp = CreateObject("Outlook.Application")
Set Outmail = OutApp.CreateItem(0)
Outmail.BodyFormat = 2
With Outmail
.To = "genceller@hotmail.com.tr"
.CC = ""
.Subject = "KONTR0L M€RK3Z1"
.Attachments.Add “D:\Şirket Evrakları\111111111.xlsm"
.Display
.Send 'Göndermek için .send den önceki ' tek tırnak işaretini kaldırın
End With
Set Outmail = Nothing: Set OutApp = Nothing
End Sub
Sub SuzYaz()
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Kson = Evaluate("=Kson")
bugun = CLng([F3])
adet = WorksheetFunction.CountIf(Range("F4:F" & Kson), bugun)
If adet = 0 Then
MsgBox [F3] & " gününe ait kayıtlı veri yok.", vbCritical
Range("$B$3:$F$3").AutoFilter Field:=5
GoTo 10
Else
Range("$B$3:$F$3").AutoFilter Field:=5, Criteria1:=">=" & CLng(bugun)
ActiveSheet.PageSetup.PrintArea = "$B$1:$G$" & Kson
ActiveSheet.PrintOut Copies:=1, ActivePrinter:="Ne00: üzerindeki P-3025 MFP KX", _
Collate:=True, IgnorePrintAreas:=False
Range("$B$3:$F$3").AutoFilter Field:=5
MsgBox [F3] & " tarihine ait veriler yazıcıya gönderildi.", vbInformation
End If
10:
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
End Sub

mc_exrem · 20 Nisan 2020

.Attachments.Add 'D:\Şirket Evrakları\111111111.xlsm'

çift tırnak yaptığımda yazı renki kırmızı oluyor ama tek tırmağa çevirince yeşil oluyor ama mail yine gelmedi?

hamitcan · 20 Nisan 2020

Muhtemelen eklemek istediğiniz dosyanın ya yolu yanlış yada ismi ve uzantısı.

mc_exrem · 20 Nisan 2020

hamitcan' Alıntı:
Muhtemelen eklemek istediğiniz dosyanın ya yolu yanlış yada ismi ve uzantısı.

yolu burdaki değil mi? (dosyanın adını değiştirdim)

mc_exrem · 21 Nisan 2020

hamitcan' Alıntı:
Muhtemelen eklemek istediğiniz dosyanın ya yolu yanlış yada ismi ve uzantısı.

Dosya yolunu bu şekilde yaptım. ama maili yine göndermedi?

Soru Makro ile hem çıktı hem de Mail Gönderme

mc_exrem

Ekli dosyalar

u.L.a.s

hamitcan

Uzman

mc_exrem

hamitcan

Uzman

mc_exrem

mc_exrem

hamitcan

Uzman

mc_exrem

hamitcan

Uzman

mc_exrem

stirra_ej

mc_exrem

stirra_ej

mc_exrem

mc_exrem

Ekli dosyalar

mc_exrem

hamitcan

Uzman

mc_exrem

mc_exrem