MS-Word 2010 - Macro to export table to Outlook Tasks

Question

I'm trying to create a macro in MS-Word VBA to take the contents of a MS-Word table (with a bookmarked name), iterate through the rows of the table and create tasks in MS-Outlook (1 row=1 task).

I have Googled and think I will need to try and mix together the following two scripts I have found:

Script 1 - (For making calendar entries - not wanted, but iteration through rows - wanted)

Sub AddAppntmnt() 
'Adds a list of events contained in a three column Word table
'with a header row, to Outlook Calendar
Dim olApp As Object
Dim olItem As Object
Dim oTable As Table
Dim i As Long
Dim bStarted As Boolean
Dim strStartDate As Range
Dim strEndDate As Range
Dim strSubject As Range
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set olApp = CreateObject("Outlook.Application")
bStarted = True
End If
Set oTable = ActiveDocument.Tables(1)

'Ignore the first (header) row of the table
For i = 2 To oTable.Rows.Count
Set strStartDate = oTable.Cell(i, 1).Range
strStartDate.End = strStartDate.End - 1
Set strEndDate = oTable.Cell(i, 2).Range
strEndDate.End = strEndDate.End - 1
Set strSubject = oTable.Cell(i, 3).Range
strSubject.End = strSubject.End - 1
Set olItem = olApp.CreateItem(1)
olItem.Start = strStartDate
olItem.End = strEndDate
olItem.ReminderSet = False
olItem.AllDayEvent = True
olItem.Subject = strSubject
olItem.Categories = "Events"
olItem.BusyStatus = 0
olItem.Save
Next i
If bStarted Then olApp.Quit
Set olApp = Nothing
Set olItem = Nothing
Set oTable = Nothing
End Sub

Script 2 - has the actual task creation bit I think I need although this one is about setting task to remind user to do something in 2 weeks or something:

Sub AddOutlookTask()
Dim olApp As Object
Dim olItem As Object
Dim bStarted As Boolean
Dim fName As String
Dim flName As String
On Error Resume Next
If ActiveDocument.Saved = False Then
ActiveDocument.Save
If Err.Number = 4198 Then
MsgBox "Process ending - document not saved!"
GoTo UserCancelled:
End If
End If
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
'Outlook wasn't running, start it from code
Set olApp = CreateObject("Outlook.Application")
bStarted = True
End If
Set olItem = olApp.CreateItem(3) 'Task Item
fName = ActiveDocument.name
flName = ActiveDocument.FullName
olItem.Subject = "Follow up " & fName
olItem.Body = "If no reply to" & vbCr & _
flName & vbCr & "further action required"
olItem.StartDate = Date + 10 '10 days from today
olItem.DueDate = Date + 14 '14 days from today
olItem.Importance = 2 'High
olItem.Categories = InputBox("Category?", "Categories")
olItem.Save
UserCancelled:
If bStarted Then olApp.Quit
Set olApp = Nothing
Set olItem = Nothing
End Sub

How do I reference a particular table in MS-Word in code? I have bookmarked it so it has a "name" if that helps!

Answer 1

With Davids help (above) I have got the following solution to my problem. I post here for others if they come across a similar issue:

Sub CreateTasks()
'
' CreateTasks Macro
'
'
'
'Exports the contents of the ACtoins table to MS-Outlook Tasks

' Set Variables
Dim olApp As Object
Dim olItem As Object
Dim oTable As Table
Dim i As Long
Dim strSubject As Range
Dim strDueDate As Range
Dim strBody As Range
Dim strSummary As String

Dim bStarted As Boolean
'Dim strPupil As WdBookmark
Dim strPerson As Range


'Link to Outlook
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set olApp = CreateObject("Outlook.Application")
bStarted = True
End If

'Set table variable to the bookmarked table
Set oTable = ActiveDocument.Bookmarks("Actions").Range.Tables(1)

'Ignore the first (header) row of the table
For i = 3 To oTable.Rows.Count

Set strSubject = oTable.Cell(i, 3).Range
strSubject.End = strSubject.End - 1


Set strBody = oTable.Cell(i, 4).Range
strBody.End = strBody.End - 1

Set strDueDate = oTable.Cell(i, 5).Range
strDueDate.End = strDueDate.End - 1



'next line not working below
'Set strPupil = WdBookmark.Name


'Create the task
Set olItem = olApp.CreateItem(3) 'Task Item

strSummary = Left(strSubject, 30)

olItem.Subject = "CYPP Action for" & " " & strBody & "-" & strSummary & "..."
olItem.Body = strBody & vbNewLine & olItem.Body & vbNewLine & strSubject
olItem.DueDate = strDueDate & olItem.DueDate
olItem.Categories = "CYPP"
olItem.Save

Next i


If bStarted Then olApp.Quit
Set olApp = Nothing
Set olItem = Nothing
Set oTable = Nothing


End Sub

I will be adding to this to deal with empty rows but I am pleased with the functionality so far. The DateDue is not working yet but I think that is a formatting issue.

Thanks again David,

Richard.