Question

我试图在MS-Word VBA中创建一个宏来获取MS-Word表的内容（带有书签名称），遍历表的行并在MS-Outlook中创建任务（ 1行= 1个任务）。

我用谷歌搜索并认为我需要尝试将我找到的以下两个脚本混合在一起：

脚本1 - （用于制作日历条目 - 不想要，但通过行迭代 - 想要）

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中的特定表？我已将它加入书签，因此它有一个＆＃34;名称＆＃34;如果有帮助的话！

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尚未运行，但我认为这是格式化问题。

再次感谢David，

理查德。

MS-Word 2010 - 将表导出到Outlook任务的宏

1 个答案: