MS-Word 2010-宏將表導出到Outlook任務

Question

我試圖在MS-Word VBA中創建一個宏來獲取MS-Word表（帶有書籤名稱）的內容，遍歷該表並在MS-Outlook中創建任務（1行= 1任務）。

我用Google搜索，並認爲我會需要嘗試和混合在一起的以下兩個腳本我發現：

腳本1 - （用於製作日曆項 - 不想要，而是通過rows iteration - 想）

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 

腳本2 - 具有實際任務創建位我想我需要儘管這是一個有關設置任務提醒用戶做一些事情在2個星期或東西：

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 

如何在代碼中引用MS-Word中的特定表格？我已經爲它添加了書籤，所以它有一個「名稱」，如果有幫助的話！

Answer 1

大衛幫助（上述）我已經得到了我的問題的以下解決方案。我張貼在這裏的人，如果他們遇到了類似的問題：

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 

我會加入到這個對付空行，但我很高興有這麼遠的功能。 DateDue沒有工作，但我認爲這是一個格式問題。

再次感謝大衛，

理查德。