excel - 从一行数据创建多个 Outlook 约会
问题描述
下面从我的 Excel 数据在 Outlook 中创建一个约会 - 有没有办法创建多个约会,而不是下面只更新一个约会的方法?我需要 3 个不同的约会(第 33、38 和 43 列中的每个日期),我的代码只进行了一次约会并更新到最后一个日期。
Sub ResolveName()
Dim OL As Outlook.Application, ES As Worksheet, _
r As Long, i As Long, wb As ThisWorkbook
Set wb = ThisWorkbook
Set ES = wb.Sheets("Licences")
Set OL = New Outlook.Application
Dim myOlApp As Outlook.Application
Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.MAPIFolder
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Dim SharedMailboxEmail As String
SharedMailboxEmail = "xxx@xxx.com"
Set outSharedName = myNamespace.CreateRecipient(SharedMailboxEmail)
Set outCalendarFolder = myNamespace.GetSharedDefaultFolder(outSharedName, olFolderCalendar)
Set outappointment = outCalendarFolder.Items.Add(olAppointmentItem)
Set myRecipient = myNamespace.CreateRecipient("DTS Streetworks")
myRecipient.Resolve
r = Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To r
With Cells(i, 5)
If myRecipient.Resolved And .Value = "TTRO" And Cells(i, 6) <> "" Then
With outappointment
.Subject = "Send Notice of Intent - " + ES.Cells(i, 4).Value + " " + ES.Cells(i, 12).Value
.Start = ES.Cells(i, 33) + TimeValue("09:00:00")
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = ES.Cells(i, 5).Value
.Save
End With
With outappointment
.Subject = "Send Notice of Making - " + ES.Cells(i, 4).Value + " " + ES.Cells(i, 12).Value
.Start = ES.Cells(i, 38) + TimeValue("09:00:00")
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = ES.Cells(i, 5).Value
.Save
End With
With outappointment
.Subject = "Send Full Order - " + ES.Cells(i, 4).Value + " " + ES.Cells(i, 12).Value
.Start = ES.Cells(i, 43) + TimeValue("09:00:00")
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = ES.Cells(i, 5).Value
.Save
End With
End If
End With
Next i
Set OL = Nothing
Set wb = Nothing
Set ES = Nothing
End Sub
Sub ShowCalendar(myNamespace, myRecipient)
Dim CalendarFolder As Outlook.MAPIFolder
Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
CalendarFolder.Display
End Sub
更新 -
根据说明新要求的评论,代码如下:
Sub ResolveNameTTRO()
Dim OL As Outlook.Application, ES As Worksheet, r As Long, i As Long, wb As ThisWorkbook
Set wb = ThisWorkbook
Set ES = wb.Sheets("Licences")
Set OL = New Outlook.Application
Dim myOlApp As Outlook.Application
Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.MAPIFolder
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Dim SharedMailboxEmail As String
SharedMailboxEmail = "xxx@xxx.com"
Set outSharedName = myNamespace.CreateRecipient(SharedMailboxEmail)
Set outCalendarFolder = myNamespace.GetSharedDefaultFolder(outSharedName, olFolderCalendar)
Set myRecipient = myNamespace.CreateRecipient("DTS Streetworks")
myRecipient.Resolve
r = Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To r
With Cells(i, 5)
If myRecipient.Resolved And .Value = "TTRO" And Cells(i, 6) <> "" Then
Set outappointment = outCalendarFolder.Items.Add(olAppointmentItem)
With outappointment
.Subject = "Send Notice of Intent - " + ES.Cells(i, 4).Value + " " + ES.Cells(i, 12).Value
.Start = ES.Cells(i, 33) + TimeValue("09:00:00")
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = ES.Cells(i, 5).Value
.Save
End With
Set outappointment = outCalendarFolder.Items.Add(olAppointmentItem)
With outappointment
.Subject = "Send Notice of Making - " + ES.Cells(i, 4).Value + " " + ES.Cells(i, 12).Value
.Start = ES.Cells(i, 38) + TimeValue("09:00:00")
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = ES.Cells(i, 5).Value
.Save
End With
Set outappointment = outCalendarFolder.Items.Add(olAppointmentItem)
With outappointment
.Subject = "Send Full Order - " + ES.Cells(i, 4).Value + " " + ES.Cells(i, 12).Value
.Start = ES.Cells(i, 43) + TimeValue("09:00:00")
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = ES.Cells(i, 5).Value
.Save
End With
If myRecipient.Resolved And .Value = "Section 50" And Cells(i, 6) <> "" Then
Set outappointment = outCalendarFolder.Items.Add(olAppointmentItem)
With outappointment
.Subject = "Send licence - " + ES.Cells(i, 4).Value + " " + ES.Cells(i, 12).Value
.Start = ES.Cells(i, 54) + TimeValue("09:00:00")
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = "Send licence to " + ES.Cells(i, 10).Value
.Save
End With
If myRecipient.Resolved And .Value = "Mobile Plant" And Cells(i, 6) <> "" Then
Set outappointment = outCalendarFolder.Items.Add(olAppointmentItem)
With outappointment
.Subject = "Send licence - " + ES.Cells(i, 4).Value + " " + ES.Cells(i, 12).Value
.Start = ES.Cells(i, 54) + TimeValue("09:00:00")
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = "Send licence to " + ES.Cells(i, 10).Value
.Save
End With
End If
End With
Next i
Set OL = Nothing
Set wb = Nothing
Set ES = Nothing
End Sub
解决方案
由于您需要创建 3 个约会,因此您需要Set outappointment = outCalendarFolder.Items.Add(olAppointmentItem)
在循环内移动并执行 3 次。修改后的代码说明了这个想法。
Sub ResolveName()
Dim OL As Outlook.Application, ES As Worksheet, r As Long, i As Long, wb As ThisWorkbook
Set wb = ThisWorkbook
Set ES = wb.Sheets("Licences")
Set OL = New Outlook.Application
Dim myOlApp As Outlook.Application
Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.MAPIFolder
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Dim SharedMailboxEmail As String
SharedMailboxEmail = "xxx@xxx.com"
Set outSharedName = myNamespace.CreateRecipient(SharedMailboxEmail)
Set outCalendarFolder = myNamespace.GetSharedDefaultFolder(outSharedName, olFolderCalendar)
Set myRecipient = myNamespace.CreateRecipient("DTS Streetworks")
myRecipient.Resolve
r = Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To r
With Cells(i, 5)
If myRecipient.Resolved And .Value = "TTRO" And Cells(i, 6) <> "" Then
Set outappointment = outCalendarFolder.Items.Add(olAppointmentItem)
With outappointment
.Subject = "Send Notice of Intent - " + ES.Cells(i, 4).Value + " " + ES.Cells(i, 12).Value
.Start = ES.Cells(i, 33) + TimeValue("09:00:00")
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = ES.Cells(i, 5).Value
.Save
End With
Set outappointment = outCalendarFolder.Items.Add(olAppointmentItem)
With outappointment
.Subject = "Send Notice of Making - " + ES.Cells(i, 4).Value + " " + ES.Cells(i, 12).Value
.Start = ES.Cells(i, 38) + TimeValue("09:00:00")
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = ES.Cells(i, 5).Value
.Save
End With
Set outappointment = outCalendarFolder.Items.Add(olAppointmentItem)
With outappointment
.Subject = "Send Full Order - " + ES.Cells(i, 4).Value + " " + ES.Cells(i, 12).Value
.Start = ES.Cells(i, 43) + TimeValue("09:00:00")
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = ES.Cells(i, 5).Value
.Save
End With
End If
End With
Next i
Set OL = Nothing
Set wb = Nothing
Set ES = Nothing
End Sub
推荐阅读
- c# - WPF MVVM 将图像源设置为空?
- python - 获取谷歌结果+结果描述
- javascript - 在useMemo中使用reducer时使用useState和useEffect错误更新状态不起作用
- python - 用户定义的异常处理后正确的一般异常处理
- tensorflow - 关于张量流 2.3.0-rc1
- java - 在我添加 throws ParseException 之后,仍然出现解析异常,为什么?
- python - 在不知道其键的情况下按值对嵌套字典列表进行排序 [Python]
- service - 从多个连接服务器重新启动多个服务
- cocoscreator - Cocos Creator:将节点位置转换为 UILocation
- c - 如何使用函数更改数组中的值