Outlook açıldığında exceldeki listeye özel günlerinde mail atmak (Bunu için en kullanışlı yol başlangıç'a outlook'u koymak).
Açılışta ve kapanışta tarihleri kontrol edip, kapanırken outlook açmayacağınız gün sayısını soruyor o tarihler arasında özel günü olan varsa mailini kapanırken sizden onay alarak gönderiyor.
Verdiğim koddan sonra aşağıdaki uyarlamalarıda kolayca yapabilirsiniz,
isterseniz excelde ve koddaki mesajda küçük değişiklikler yapıp çalışanlarınıza bu gün ne yaptın maili gönderebilirsiniz veya eklemelerle toplu değil kişiye özel mail atabilirsiniz.
c:\PersonelOzelGunleri.csv(excelde oluşturduğunuz tabloyu .csv olarak kaydedin)
içeriği örnek olarak aşağıda verilmiştir, listenizi oluşturun.
sıra;adı soyadı;mail adresi;durum(e/d);gün;ay
1;demir zined;demir.zined@xxx.com;d;13;9
Kodu sadece yapıştırmanız yeterli değişiklik yapmak istersenizde kolay olacaktır (outlook kod bölümüne).
Private Sub Application_Startup()
On Error Resume Next
Dim MyDate, MyDay, MyMonth, MyItem
Dim InputData
MyDate = Date
MyDay = Day(MyDate)
MyMonth = Month(MyDate)
MyDate1 = (MyDay & "." & MyMonth)
Open "c:\PersonelOzelGunleri.csv" For Input As #1
Do While Not EOF(1)
Line Input #1, InputData
virgul = InStrRev(InputData, ";", -1)
MidDogAy = Mid(InputData, virgul + 1)
TrimDogAy = Trim(MidDogAy)
DogAy = Val(TrimDogAy)
InputData = Mid(InputData, 1, virgul - 1)
virgul = InStrRev(InputData, ";", -1)
MidDogGun = Mid(InputData, virgul + 1)
TrimDogGun = Trim(MidDogGun)
DogGun = Val(TrimDogGun)
DogTar = DogGun & "." & DogAy
If MyDate1 = DogTar Then
InputData = Mid(InputData, 1, virgul - 1)
virgul = InStrRev(InputData, ";", -1)
MidDurum = Mid(InputData, virgul + 1)
TrimDurum = Trim(MidDurum)
If TrimDurum = "e" Then
mesMesajBox = " Evlilik Yıldönümü..."
mesSubject = "Evlilik Yıl Dönümünüzü Kutlarım..."
mesBody = "<HTML><H4>Bir Ömür Boyu Mutluluklar...</H4><BODY>demir.zined<br><br></BODY></HTML>"
Else
mesMesajBox = " Doğum Günü..."
mesSubject = "Doğum Gününüzü Kutlarım..."
mesBody = "<HTML><H4>Nice YILLARA...</H4><BODY>demir.zined<br><br></BODY></HTML>"
End If
InputData = Mid(InputData, 1, virgul - 1)
virgul = InStrRev(InputData, ";", -1)
MidMail = Mid(InputData, virgul + 1)
TrimMail = Trim(MidMail)
InputData = Mid(InputData, 1, virgul - 1)
virgul = InStrRev(InputData, ";", -1)
MidAdSad = Mid(InputData, virgul + 1)
TrimAdSad = Trim(MidAdSad)
InputData = Mid(InputData, 1, virgul - 1)
virgul = InStrRev(InputData, ";", -1)
MidSn = Mid(InputData, virgul + 1)
TrimSn = Trim(MidSn)
MailCevap = MsgBox((MyDate1 & " / " & TrimSn & TrimAdSad & mesMesajBox), vbOKCancel, "Mail Gönder!!!")
If MailCevap = 1 Then
Set MyItem = Outlook.CreateItem(olMailItem)
MyItem.To = TrimMail
MyItem.Subject = mesSubject & "(" & TrimAdSad & " - " & MyDate1 & ")"
MyItem.HTMLBody = mesBody
MyItem.Send
End If
End If
Loop
Close #1
End Sub
Private Sub Application_Quit()
On Error Resume Next
Dim Message, Title, Default, MyValue, MyItem
Message = "Kaç gün mesaide olmayacaksınız? (Haftasonu=2)"
Title = "Çıkış"
Default = "2"
MyValue = InputBox(Message, Title, Default)
If MyValue = "" Then
Exit Sub
ElseIf MyValue = 0 Then
Exit Sub
Else
Counter = 0
For Counter = 1 To MyValue
MyDate = Date + Counter
MyDay = Day(MyDate)
MyMonth = Month(MyDate)
MyDate1 = (MyDay & "." & MyMonth)
Open "c:\PersonelOzelGunleri.csv" For Input As #1
Do While Not EOF(1)
Line Input #1, InputData
virgul = InStrRev(InputData, ";", -1)
MidDogAy = Mid(InputData, virgul + 1)
TrimDogAy = Trim(MidDogAy)
DogAy = Val(TrimDogAy)
InputData = Mid(InputData, 1, virgul - 1)
virgul = InStrRev(InputData, ";", -1)
MidDogGun = Mid(InputData, virgul + 1)
TrimDogGun = Trim(MidDogGun)
DogGun = Val(TrimDogGun)
DogTar = DogGun & "." & DogAy
If MyDate1 = DogTar Then
InputData = Mid(InputData, 1, virgul - 1)
virgul = InStrRev(InputData, ";", -1)
MidDurum = Mid(InputData, virgul + 1)
TrimDurum = Trim(MidDurum)
If TrimDurum = "e" Then
mesMesajBox = " Evlilik Yıldönümü..."
mesSubject = "Evlilik Yıl Dönümünüzü Kutlarım..."
mesBody = "<HTML><H4>Bir Ömür Boyu Mutluluklar...</H4><BODY>demir.zined<br><br></BODY></HTML>"
Else
mesMesajBox = " Doğum Günü..."
mesSubject = "Doğum Gününüzü Kutlarım..."
mesBody = "<HTML><H4>Nice YILLARA...</H4><BODY>demir.zined<br><br></BODY></HTML>"
End If
InputData = Mid(InputData, 1, virgul - 1)
virgul = InStrRev(InputData, ";", -1)
MidMail = Mid(InputData, virgul + 1)
TrimMail = Trim(MidMail)
InputData = Mid(InputData, 1, virgul - 1)
virgul = InStrRev(InputData, ";", -1)
MidAdSad = Mid(InputData, virgul + 1)
TrimAdSad = Trim(MidAdSad)
InputData = Mid(InputData, 1, virgul - 1)
virgul = InStrRev(InputData, ";", -1)
MidSn = Mid(InputData, virgul + 1)
TrimSn = Trim(MidSn)
MailCevap = MsgBox((MyDate1 & " / " & TrimSn & TrimAdSad & mesMesajBox), vbOKCancel, "Mail Gönder!!!")
If MailCevap = 1 Then
Set MyItem = Outlook.CreateItem(olMailItem)
MyItem.To = TrimMail
MyItem.Subject = mesSubject & "(" & TrimAdSad & " - " & MyDate1 & ")"
MyItem.HTMLBody = mesBody
MyItem.Send
End If
End If
Loop
Close #1
Next Counter
End If
End Sub
SORU ve CEVAPLAR (Yazılabilir)
Konu: Outlook Açıldığında Excel'deki Listeye Özel Günlerinde Mail, (Okunma sayısı 10104 defa)