Создание нескольких встреч Outlook из одной строки данных

Приведенное ниже создает встречу в 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

outlook excel vba
person ffc2004    schedule 14.08.2019    source источник
comment
Формат сайта предусматривает один вопрос в каждом сообщении, поэтому можно получить принятый ответ. Удалите правку и задайте отдельный вопрос по теме. Таким образом, вы можете принять там ответ, если хотите. Вы не можете принять два ответа на один и тот же вопрос.   -  person niton    schedule 14.08.2019

Ответы (2)


arrow_upward
1
arrow_downward

Поскольку вам нужно создать 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 = "[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
          End If
        End With
    Next i

    Set OL = Nothing
    Set wb = Nothing
    Set ES = Nothing
End Sub
person Brian M Stafford    schedule 14.08.2019

arrow_upward
0
arrow_downward

Для каждого раза, указанного в строке Excel, вам просто нужно повторить следующий вызов:

Set outappointment = outCalendarFolder.Items.Add(olAppointmentItem)
person Eugene Astafiev    schedule 14.08.2019
comment
Теперь я пытаюсь заставить его создавать встречи на основе значения ячейки - если значение равно TTRO, как указано выше, он создаст 3 встречи, которые теперь работают, однако затем я также хочу, чтобы он продолжал проверять значения и назначать встречу на дата в столбце BB (54). Пробовали исправленный код в исходном сообщении, но не повезло? - person ffc2004; 14.08.2019