以下内容通过我的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
答案 0 :(得分:1)
由于需要创建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
答案 1 :(得分:0)
对于Excel行中指定的每次时间,您只需要重复以下调用:
Set outappointment = outCalendarFolder.Items.Add(olAppointmentItem)