R
Rick Williams
This macro will do it. Paste the code in the MS Project VB Editor, go to
Tools, References, and check Micosoft Outlook Object Model, and it should
work for you.
Regards,
Rick Williams
Sub OutlookLinkAppt()
Dim appOL As Outlook.Application
Dim mspTask As MSProject.Task
Dim olAppt As Outlook.AppointmentItem
Dim i As Integer
Dim j As Integer
On Error GoTo objerror
Set appOL = GetObject(, "Outlook.Application") ' if Outlook is running,
this line will work
resumeplace:
For Each mspTask In MSProject.ActiveProject.Tasks
If Not (mspTask Is Nothing) Then
Set olAppt = appOL.CreateItem(olAppointmentItem)
'note that you can capture other Project fields into Outlook fields
olAppt.Subject = mspTask.Name
olAppt.Body = mspTask.Name
olAppt.Start = mspTask.EarlyStart
olAppt.End = mspTask.EarlyFinish
olAppt.Mileage = mspTask.ID
If mspTask.Resources.Count > 0 Then
For j = 1 To mspTask.Resources.Count
olAppt.Recipients.Add mspTask.Resources(j).Name
olAppt.Save
Next j
End If
olAppt.Save
Set olAppt = Nothing
End If
i = i + 1
Next
MsgBox i & " tasks were exported to Outlook as appointments!"
Exit Sub
objerror: ' if Outlook is not running, this will work
Err.Clear
Set appOL = CreateObject("Outlook.Application")
GoTo resumeplace
End Sub
Tools, References, and check Micosoft Outlook Object Model, and it should
work for you.
Regards,
Rick Williams
Sub OutlookLinkAppt()
Dim appOL As Outlook.Application
Dim mspTask As MSProject.Task
Dim olAppt As Outlook.AppointmentItem
Dim i As Integer
Dim j As Integer
On Error GoTo objerror
Set appOL = GetObject(, "Outlook.Application") ' if Outlook is running,
this line will work
resumeplace:
For Each mspTask In MSProject.ActiveProject.Tasks
If Not (mspTask Is Nothing) Then
Set olAppt = appOL.CreateItem(olAppointmentItem)
'note that you can capture other Project fields into Outlook fields
olAppt.Subject = mspTask.Name
olAppt.Body = mspTask.Name
olAppt.Start = mspTask.EarlyStart
olAppt.End = mspTask.EarlyFinish
olAppt.Mileage = mspTask.ID
If mspTask.Resources.Count > 0 Then
For j = 1 To mspTask.Resources.Count
olAppt.Recipients.Add mspTask.Resources(j).Name
olAppt.Save
Next j
End If
olAppt.Save
Set olAppt = Nothing
End If
i = i + 1
Next
MsgBox i & " tasks were exported to Outlook as appointments!"
Exit Sub
objerror: ' if Outlook is not running, this will work
Err.Clear
Set appOL = CreateObject("Outlook.Application")
GoTo resumeplace
End Sub