'****
' procedure to assist in deletion of user accounts cutting down the keystrokes
' prompt for username(s) and create a calendar appointment
'
' Author Jim Ward
' Creation 16th April 2010
'****
'
Sub DeleteAccountAppoint()
Dim EndDate As Date
Dim FutureDate As Date
'
'****
' Get a list of username(s)
'****
'
Dim strName As String
strName = InputBox(Prompt:="Enter User To Be Deleted", _
Title:="Enter User Name", Default:="Users Name here")
If strName = "Users Name here" Or strName = vbNullString Then
Exit Sub
End If
'
'****
' Get Requestor Name
'****
'
Dim ReqName As String
ReqName = InputBox(Prompt:="Who Requested The Deletion (FirstName Surname)", _
Title:="Enter Name", Default:="Requesting Name here")
If ReqName = "Requesting Name here" Or strName = vbNullString Then
Exit Sub
End If
'
'****
' Get Todays date, add 30 days
' check if saturday or sunday advance if needed
' add 8 hours
'****
'
FutureDate = Date + 30
wDay = Weekday(FutureDate, vbMonday)
If wDay = 6 Then
FutureDate = FutureDate + 2
End If
If wDay = 7 Then
FutureDate = FutureDate + 1
End If
'
'****
' Add 8 hours as the above sets to midnight, then add 15mins for 08:15
'****
'
FutureDate = FutureDate + TimeSerial(8, 0, 0)
EndDate = FutureDate + TimeSerial(0, 15, 0)
'
'****
' Create appointment
'****
'
CreateAppointment "Account Deletion", "Delete Accounts for " + strName, FutureDate, EndDate, False
MsgBox ("Deletion Appointment Created for " & strName & " on " & FutureDate)
End Sub
'
'****
'Function to create calendar item, nabbed from my friend google
'****
'
Public Function CreateAppointment(SubjectStr As String, BodyStr As String, StartTime As Date, EndTime As Date, AllDay As Boolean)
Dim OlApp As Outlook.Application
Dim Appt As Outlook.AppointmentItem
Set OlApp = CreateObject("Outlook.Application")
Set Appt = OlApp.CreateItem(olAppointmentItem)
Appt.Subject = SubjectStr
Appt.Start = StartTime
Appt.End = EndTime
Appt.AllDayEvent = AllDay
Appt.Body = BodyStr
Appt.Save
Set Appt = Nothing
Set OlApp = Nothing
End Function