Создание событие в календаре Outlook из Excel на один год

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Создание событие в календаре Outlook из Excel на один год (Макросы/Sub)

Anis625

Дата: Понедельник, 21.02.2022, 11:14 | Сообщение № 1

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

Excel 2013

Добрый день, всем участникам форума.
Есть рабочий код (нашли на импортном форуме с небольшими своими доработками):
[vba]

Код

Sub ImportMeetingToCalendar()
    Dim objWorksheet As Excel.Worksheet
    Dim nLastRow As Integer
    Dim objOutlookApp As Outlook.Application
    Dim objCalendar As Outlook.Folder
    Dim objBirthdayEvent As Outlook.AppointmentItem
    Dim objRecurrencePattern As Outlook.RecurrencePattern

    'Get the specific sheet
        Set objWorksheet = ThisWorkbook.Sheets(1)
    nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row

    Set objOutlookApp = CreateObject("Outlook.Application")
    Set objCalendar = objOutlookApp.Session.GetDefaultFolder(olFolderCalendar)

    For nRow = 2 To nLastRow
        Set objBirthdayEvent = objCalendar.Items.Add("IPM.Appointment")

        'Create events
        With objBirthdayEvent
            .AllDayEvent = True
            .BusyStatus = 0
            .Subject = objWorksheet.Range("A" & nRow)
            .Start = objWorksheet.Range("B" & nRow)
            .End = objWorksheet.Range("C" & nRow)
            .Body = objWorksheet.Range("D" & nRow)
            .Categories = objWorksheet.Range("E" & nRow)
            .ReminderSet = True
            .ReminderMinutesBeforeStart = objWorksheet.Range("F" & nRow).Value

         Set objRecurrencePattern = .GetRecurrencePattern
         objRecurrencePattern.RecurrenceType = olRecursYearly
            .Save
        End With
    Next
End Sub

[/vba]
Но он создает события на каждый год. Подскажите, пожалуйста, что-необходимо изменить чтобы события создавались только на один год?

Код

[/vba]
Но он создает события на каждый год. Подскажите, пожалуйста, что-необходимо изменить чтобы события создавались только на один год?Anis625

Ответить

СообщениеДобрый день, всем участникам форума.
Есть рабочий код (нашли на импортном форуме с небольшими своими доработками):
[vba]

Код

Автор - Anis625
Дата добавления - 21.02.2022 в 11:14

Anis625

Дата: Понедельник, 21.02.2022, 13:38 | Сообщение № 2

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

Excel 2013

Решение нашлось такое:
[vba]

Код

Sub ImportMeetingToCalendar()
    Dim objWorksheet As Excel.Worksheet
    Dim nLastRow As Integer
    Dim objOutlookApp As Outlook.Application
    Dim objCalendar As Outlook.Folder
    Dim objBirthdayEvent As Outlook.AppointmentItem
    Dim objRecurrencePattern As Outlook.RecurrencePattern

    'Get the specific sheet
        Set objWorksheet = ThisWorkbook.Sheets(1)
    nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row

    Set objOutlookApp = CreateObject("Outlook.Application")
    Set objCalendar = objOutlookApp.Session.GetDefaultFolder(olFolderCalendar)

    For nRow = 2 To nLastRow
        Set objBirthdayEvent = objCalendar.Items.Add("IPM.Appointment")

        'Create events
        With objBirthdayEvent
            .AllDayEvent = True
            .BusyStatus = 0
            .Subject = objWorksheet.Range("A" & nRow)
            .Start = objWorksheet.Range("B" & nRow)
            .End = objWorksheet.Range("C" & nRow)
            .Body = objWorksheet.Range("D" & nRow)
            .Categories = objWorksheet.Range("E" & nRow)
            .ReminderSet = True
            .ReminderMinutesBeforeStart = objWorksheet.Range("F" & nRow).Value

        'Set objRecurrencePattern = .GetRecurrencePattern
        'objRecurrencePattern.RecurrenceType = olRecursYearly
            .Save
        End With
    Next
End Sub

[/vba]

Закомментировал нижние строки