Solved: Days Until Countdown

[Paul_Hossler]

Is there a macro or another way to add a 'Days Remaining' all day event to Outlook?

I'd like to be able to enter an End Date (aka 'D-Day') and have the D-Day minus XX Days entered into the calendar.

Ex. I enter D-Day = Aug 25 + "Birthday", and since today is Aug 21 the macro generates events

Aug25 = Birthday
Aug24 = Birthday-1
Aug23 = Birthday-2
Aug22 = Birthday-3
Aug21 = Birthday-4

Not exactly earth shaking, but it'd be a lot easier that by hand

Paul

[JP2112]

Something like this?


Sub AddAllDayEvents()
Dim enddate As String
Dim eventName As String
Dim i As Long
Dim appt As Outlook.AppointmentItem
enddate = InputBox("Enter the due date")
eventName = InputBox("The event name?")
For i = Date To CDate(enddate)
Set appt = Outlook.CreateItem(olAppointmentItem)

With appt
.AllDayEvent = True
If i < CDate(enddate) Then ' show countdown
.Subject = eventName & " in " & Format(CDate(enddate) - i, "#####") & " day(s)"
Else ' last day!
.Subject = eventName
.Start = i
.Save
End With
Next i
End Sub

[Paul_Hossler]

Something like this?



Something exactly like that !!!! :beerchug:

I added a little error checking because I can't type, and a few more settings and it's working VERY well. Thanks


Option Explicit

Sub AddAllDayEvents()
Dim sEndDate As String
Dim sEventName As String
Dim i As Long, iDaysToGo As Long
Dim oAppt As Outlook.AppointmentItem

sEndDate = InputBox("Enter the due date")
If Not IsDate(sEndDate) Then
Call MsgBox(sEndDate & " is not a date", vbCritical + vbOKOnly, "AddAllDayEvents")
Exit Sub
End If


If CDate(sEndDate) <= Date Then
Call MsgBox(sEndDate & " is or or before today", vbCritical + vbOKOnly, "AddAllDayEvents")
Exit Sub
End If


sEventName = InputBox("The event name?")
If Len(Trim(sEventName)) = 0 Then
Call MsgBox(sEventName & " does not contain any data", vbCritical + vbOKOnly, "AddAllDayEvents")
Exit Sub
End If


For i = Date To CDate(sEndDate)
Set oAppt = Outlook.CreateItem(olAppointmentItem)

iDaysToGo = CDate(sEndDate) - i

With oAppt
.AllDayEvent = True
.BusyStatus = olFree
.ReminderSet = False
.ReminderMinutesBeforeStart = 0
.Categories = "Business"

Select Case iDaysToGo
Case 0
.Subject = sEventName & "!!!"
.Start = i
.Save

Case 1
.Subject = sEventName & " in 1 day"
.Start = i
.Save

Case Else
.Subject = sEventName & " in " & Format(CDate(sEndDate) - i, "##,###") & " days"
.Start = i
.Save
End Select
End With
Next i
End Sub


Paul

[JP2112]

Of course you'll need some error checking, great job. I forgot an "End If" in my code, no idea how that happened but glad to see it worked out for you.