VBA to Assign Outlook Task

[Jim]

I'm using Excel Office 2007. I would like a VBA code to create a task in
Outlook based on a date in an Excel workbook. Once the task is completed, I
would like that completion date entered into the Excel Workbook. Is this
possible?

My initial date is located in the workbook 'Loan Book', worksheet 'Loan
Data' cell CN9. I would like the task completion due date to be four days
prior to the sheet date. Once the task is completed, I would like that
completion date CP9.

Thanks in advance for any advice.

 

[Joel]

It is posisible but I think it needs to be done the opposite way.


The macro needs to be written in Outlook VBA not excel VBA. When the event
is finished that event would be recognized in Outlook VBA (not excel VBA).
Since it is possible to open an excel workbook from Outlook it would be
better that.

You will need to setup a module code in Outllok to create a calendar event.
This code would open the workbook. You will also need a class module
inoutlook so when the calendar event occurs again open the workbook up a
enter into the workbook that the event completed.

I sample of the code to create the event is shown below. It may be better
to ask additional questions about outlook at the outlook programming website.


Public Sub cmdExample()

Set excelobj = getobject("c:\Myappointment\book1.xls")
MyDate = excelobj.sheets("sheet1").Range("A1")


Set myOlApp = New Outlook.Application
Set myApptItem = myOlApp.CreateItem(olAppointmentItem)
myApptItem.Start = Mydate
myApptItem.End = #2/2/1998 4:00:00 PM#
myApptItem.Subject = "Meet with Boss"

'Get the recurrence pattern for this appointment
'and set it so that this is a daily appointment
'that begins on 2/2/98 and ends on 2/2/99
'and save it.
Set myRecurrPatt = myApptItem.GetRecurrencePattern
myRecurrPatt.RecurrenceType = olRecursDaily
myRecurrPatt.PatternStartDate = #2/2/1998#
myRecurrPatt.PatternEndDate = #2/2/1999#
myApptItem.Save

'Access the items in the Calendar folder to locate
'the master AppointmentItem for the new series.
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderCalendar)
Set myItems = myFolder.Items
Set myApptItem = myItems("Meet with Boss")

'Get the recurrence pattern for this appointment
'and obtain the occurrence for 3/12/98.
myDate = #3/12/1998 3:00:00 PM#
Set myRecurrPatt = myApptItem.GetRecurrencePattern
Set myOddApptItem = myRecurrPatt.GetOccurrence(myDate)

'Save the existing subject. Change the subject and
'starting time for this particular appointment
'and save it.
saveSubject = myOddApptItem.Subject
myOddApptItem.Subject = "Meet NEW Boss"
newDate = #3/12/1998 3:30:00 PM#
myOddApptItem.Start = newDate
myOddApptItem.Save

'Get the recurrence pattern for the master
'AppointmentItem. Access the collection of
'exceptions to the regular appointments.
Set myRecurrPatt = myApptItem.GetRecurrencePattern
Set myException = myRecurrPatt.Exceptions.Item(1)

'Display the original date, time, and subject
'for this exception.
MsgBox myException.OriginalDate & ": " & saveSubject

'Display the current date, time, and subject
'for this exception.
MsgBox myException.AppointmentItem.Start & ": " & _
myException.AppointmentItem.Subject
End Sub

 

[JP Ronse]

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