Hi Jim,
Hereafter some code I'm using to create and send outlook tasks to my
colleagues. It's Excel 2003 VBA but think it should work also in 2007.
The code is probably not answering your question in a direct way, but you
should be able to find in it how to create a task in outlook using excel.
Wkr,
JP Ronse
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Procedure: AssignTask(rngActiveCell as range)
'''
''' Comments:
'''
'''
''' © 2004 Jean-Pierre Degroote
'''
''' Date Developer Action
''' -------------------------------------------------------------------------
''' 26/12/2004 Jean-Pierre Degroote Created
'''
Sub AssignTask(rngActiveCell As Range)
Dim strMailAddress As String
Dim strFirstName As String
Dim strCommentText As String
Dim varSendDisplay As Variant
Dim dblStartTime As Double
Dim dblEndTime As Double
On Error Resume Next
''' check if a mail address is valid
strMailAddress = Application.VLookup(Cells(2, rngActiveCell.Column),
Sheets("Engineers").Cells(1, 1).CurrentRegion, 3, False)
'''strMailAddress = TranslateName(Cells(2, rngActiveCell.Column),
strFirstName)
strFirstName = Application.VLookup(Cells(2, rngActiveCell.Column),
Sheets("Engineers").Cells(1, 1).CurrentRegion, 2, False)
gintPos = InStr(1, strMailAddress, "@", vbTextCompare)
If gintPos = 1 Then GoTo Exit_Notify
strCommentText = rngActiveCell.Comment.Text
''' if chr(10) limit to first
gintPos = InStr(1, strCommentText, Chr(10), vbTextCompare)
If gintPos > 0 Then
strCommentText = Left(strCommentText, gintPos - 1)
End If
''' remove T! mark
If InStr(1, strCommentText, "!") = 2 Then
strCommentText = Mid(strCommentText, 4)
End If
Set gobjOutlook = GetObject(, "Outlook.application")
Set gobjTask = gobjOutlook.CreateItem(olTaskItem)
With gobjTask
gintPos = InStr(1, strCommentText, " ", vbTextCompare)
If gintPos = 0 Then
.Subject = rngActiveCell & " " & strCommentText & ": Task
Assignment"
Else
.Subject = rngActiveCell & " " & Left(strCommentText, gintPos -
1) & ": Task Assignment"
End If
.Body = "Dear " & strFirstName & vbCr & vbCr
If gintPos = 0 Then
.Body = .Body & "Please accept this task: " & rngActiveCell & "
" & strCommentText
Else
.Body = .Body & "Please accept this task: " & rngActiveCell & "
" & Left(strCommentText, gintPos - 1)
End If
.Body = .Body & vbCr & vbCr
.Body = .Body & "Best regards," & vbCr
.Body = .Body & PlanningUser & vbCr & vbCr
''' add comment to body
.Body = .Body & rngActiveCell.Comment.Text
.startdate = Cells(rngActiveCell.Row, 1)
.DueDate = .startdate + Mid(strCommentText, InStr(1, strCommentText,
"/", vbTextCompare) + 1)
''' correct due date, check if owner is working
gintPos = .DueDate - .startdate
Do While gintPos >= 1
Select Case rngActiveCell.Offset(gintPos, 0)
Case "M", "A", "N", "D", "D1", "D2", "D3", "AS35"
Exit Do
Case Else
''' correct duedate
.DueDate = .DueDate - 1
gintPos = gintPos - 1
End Select
Loop
''' add task from startdate to duedate
For gintPos = 1 To .DueDate - .startdate
Select Case rngActiveCell.Offset(gintPos, 0)
Case "M", "A", "N", "D", "D1", "D2", "D3"
If HasComment(rngActiveCell.Offset(gintPos, 0)) Then
rngActiveCell.Offset(gintPos, 0).Comment.Text
Text:=strCommentText & Chr(10) & rngActiveCell.Offset(gintPos,
0).Comment.Text
Else
AddComment rngActiveCell.Offset(gintPos, 0),
strCommentText
End If
rngActiveCell.Offset(gintPos, 0).Interior.ColorIndex =
CLR_ATTENTION
End Select
Next gintPos
Set gobjMailAddress = .Recipients.Add(strMailAddress)
'''Set gobjMailAddress = .Recipients.Add("(e-mail address removed)")
'''gobjMailAddress.Type = olBCC
'''gobjMailAddress.Type = olCC
.Assign
'''.StatusReport
.StatusOnCompletionRecipients = "(e-mail address removed)"
'''.StatusUpdateRecipients = "(e-mail address removed)"
.ReminderSet = True
.ReminderTime = .DueDate - 1
.Display
End With
Set gobjTask = Nothing
Set gobjOutlook = Nothing
With rngActiveCell.Interior
.ColorIndex = CLR_TASKS
.Pattern = xlCrissCross
.PatternColorIndex = 15
End With
Exit_Notify:
On Error GoTo 0
End Sub