Private Function addOutlookTask(dt_startdate As Date, _
dt_enddate As Date, _
str_body As String, _
str_mileage As String, _
str_subject As String) As Boolean
Dim olApp As Outlook.Application
Dim oTask As TaskItem
Dim bln_QuitOutlook As Boolean 'if outlook is not open then set this to true and close outlook at the end
Dim dt_remindertime As String
On Error GoTo ErrorHandler
Set olApp = GetObject(, "Outlook.Application")
Set oTask = olApp.CreateItem(olTaskItem)
With oTask
.StartDate = Format(dt_startdate, "Short Date") & " " & Format("9.00", "Short Time")
.DueDate = Format(dt_enddate, "Short Date") & " " & Format("17.00", "Short Time")
.Status = olTaskInProgress
If DateDiff("d", .StartDate, .DueDate) > 5 Then
dt_remindertime = Format((DateAdd("d", (Int(0.75 * DateDiff("d", .StartDate, .DueDate))), .StartDate)), "Short Date") & _
" " & Format("9.00", "Short Time")
Select Case Weekday(dt_remindertime, vbMonday)
Case 6
dt_remindertime = DateAdd("d", -1, dt_remindertime)
Case 7
dt_remindertime = DateAdd("d", -2, dt_remindertime)
End Select
Else
dt_remindertime = DateAdd("d", -2, .DueDate)
End If
.Mileage = str_mileage
.ReminderSet = True
.ReminderTime = dt_remindertime
.Subject = str_subject
.body = str_body
.Save
End With
Set oTask = Nothing
If bln_QuitOutlook Then
olApp.Quit
End If
Set olApp = Nothing
addOutlookTask = True
ErrorHandlerExit:
Set oTask = Nothing
Set olApp = Nothing
Exit Function
ErrorHandler:
'Outlook is not running; open Outlook with CreateObject
If Err.Number = 429 Then
Set olApp = CreateObject("Outlook.Application")
bln_QuitOutlook = True
Resume Next
Else
MsgBox "Error No: " & Err.Number _
& "; Description: " & Err.Description
Resume ErrorHandlerExit
End If
End Function
|
