По-долу създава среща в Outlook от моите данни в Excel - има ли някакъв начин за създаване на множество срещи, вместо това, което прави по-долу, което просто актуализира една среща? Ще ми трябват 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 = "[email protected]"
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 = "[email protected]"
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
