The goal is to email my Calendar every day, along with the previous days for that week. For example, on Thursday - send Monday through Thursday. It usually works fine, but some days it sends the current date and way too many previous days. Attached is the program Could someone please help me figure out why this works some days and doesn't other days? Here is the program:
Public Sub SendCalendar()
Dim oNamespace As NameSpace
Dim oFolder As Folder
Dim oCalendarSharing As CalendarSharing
Dim objMail As MailItem
Dim dtToday As Date
Dim dtOneDayAgo As Date
Dim dtTwoDaysAgo As Date
Dim dtThreeDaysAgo As Date
Dim dtFourDaysAgo As Date
Dim iWeekday As Integer
Set oNamespace = Application.GetNamespace("MAPI")
Set oFolder = oNamespace.GetDefaultFolder(olFolderCalendar)
Set oCalendarSharing = oFolder.GetCalendarExporter
dtToday = Date
dtOneDayAgo = DateAdd("d", -1, Date)
dtTwoDaysAgo = DateAdd("d", -2, Date)
dtThreeDaysAgo = DateAdd("d", -3, Date)
dtFourDaysAgo = DateAdd("d", -4, Date)
iWeekday = Weekday(Date)
If iWeekday = 2 Then
lDays = dtToday
ElseIf iWeekday = 3 Then
lDays = dtToday And dtOneDayAgo
ElseIf iWeekday = 4 Then
lDays = dtToday And dtTwoDaysAgo
ElseIf iWeekday = 5 Then
lDays = dtToday And dtThreeDaysAgo
ElseIf iWeekday = 6 Then
lDays = dtToday And dtFourDaysAgo
End If
With oCalendarSharing
.CalendarDetail = olFreeBusyAndSubject
.IncludeWholeCalendar = False
.IncludeAttachments = False
.IncludePrivateDetails = True
.RestrictToWorkingHours = False
.StartDate = dtFourDaysAgo
.EndDate = dtToday
End With
Set objMail = oCalendarSharing.ForwardAsICal(olCalendarMailFormatDailySchedule)
With objMail
'.Display
SendKeys "{TAB}" & "{TAB}" & "{TAB}" & "{DEL}" & "{DEL}"
.Recipients.Add "staff@xyzcompany.com"
.Subject = "EODR " & Format(Date, "mm-dd-yyyy")
.Attachments.Remove (1)
.Send
End With
Set oCalendarSharing = Nothing
Set oFolder = Nothing
Set oNamespace = Nothing
End Sub
Reply
Report
Public Sub SendCalendar()
Dim oNamespace As NameSpace
Dim oFolder As Folder
Dim oCalendarSharing As CalendarSharing
Dim objMail As MailItem
Dim dtToday As Date
Dim dtOneDayAgo As Date
Dim dtTwoDaysAgo As Date
Dim dtThreeDaysAgo As Date
Dim dtFourDaysAgo As Date
Dim iWeekday As Integer
Set oNamespace = Application.GetNamespace("MAPI")
Set oFolder = oNamespace.GetDefaultFolder(olFolderCalendar)
Set oCalendarSharing = oFolder.GetCalendarExporter
dtToday = Date
dtOneDayAgo = DateAdd("d", -1, Date)
dtTwoDaysAgo = DateAdd("d", -2, Date)
dtThreeDaysAgo = DateAdd("d", -3, Date)
dtFourDaysAgo = DateAdd("d", -4, Date)
iWeekday = Weekday(Date)
If iWeekday = 2 Then
lDays = dtToday
ElseIf iWeekday = 3 Then
lDays = dtToday And dtOneDayAgo
ElseIf iWeekday = 4 Then
lDays = dtToday And dtTwoDaysAgo
ElseIf iWeekday = 5 Then
lDays = dtToday And dtThreeDaysAgo
ElseIf iWeekday = 6 Then
lDays = dtToday And dtFourDaysAgo
End If
With oCalendarSharing
.CalendarDetail = olFreeBusyAndSubject
.IncludeWholeCalendar = False
.IncludeAttachments = False
.IncludePrivateDetails = True
.RestrictToWorkingHours = False
.StartDate = dtFourDaysAgo
.EndDate = dtToday
End With
Set objMail = oCalendarSharing.ForwardAsICal(olCalendarMailFormatDailySchedule)
With objMail
'.Display
SendKeys "{TAB}" & "{TAB}" & "{TAB}" & "{DEL}" & "{DEL}"
.Recipients.Add "staff@xyzcompany.com"
.Subject = "EODR " & Format(Date, "mm-dd-yyyy")
.Attachments.Remove (1)
.Send
End With
Set oCalendarSharing = Nothing
Set oFolder = Nothing
Set oNamespace = Nothing
End Sub
Reply
Report