Встречи Outlook перезаписываются при создании из цикла Excel

Я прокручиваю информацию на листе Excel, чтобы создавать встречи в Outlook. Это работало, когда я отправил его в папку по умолчанию.

Я внес изменения, чтобы загрузить данные в определенную папку (общую для коллег).

С тех пор, когда я нажимаю F8 в своем коде, он сохраняет встречу для зацикленной строки. Однако, когда я перехожу к следующей строке, новая встреча заменяет старую, а не сохраняется.

Sub ExportToOutlook        

Dim OL as Outlook.Application, Appoint as Outlook.AppointmentItem, ES as Worksheet, _ 
        r as Long, i as Long, WB as ThisWorkook, oFolder as Object, o NameSpace as Namespace

    Set WB = ThisWorkbook
    Set ES = WB.Sheets("Export Sheet")
    r = ES.Cells(Rows.count,1).End(xlUp).Row
    Set OL = New Outlook.Application
    Set oNameSpace = OL.GetNamespace("MAPI")
    Set oFolder = oNameSpace.GetFolderFromID("Insert the ID").Items.Add(olAppointmentItem)

For i = 2 to r
    With oFolder
        .Subject = ES.Cells(i,1).Value
        .Start = ES.Cells(i,2).Value
        .End = ES.Cells(i,3).Value
        .Location = ES.Cells(i,4).Value
        .AllDayEvent = ES.Cells(i,5).Value
        .Categories = ES.Cells(i,6).Value & " Category"
        .Save
    End With
Next i

Set OL = Nothing

End Sub

outlook excel outlook-calendar vba
person JustinShotMe    schedule 19.12.2017    source источник

Ответы (2)


arrow_upward
1
arrow_downward

Кажется, вы повторно обновляете одну и ту же папку на каждой итерации строки. Попробуйте следующее:

Sub ExportToOutlook        

Dim OL as Outlook.Application, Appoint as Outlook.AppointmentItem, ES as Worksheet, _ 
        r as Long, i as Long, WB as ThisWorkook, oFolder as Object, o NameSpace as Namespace

    Set WB = ThisWorkbook
    Set ES = WB.Sheets("Export Sheet")
    r = ES.Cells(Rows.count,1).End(xlUp).Row
    Set OL = New Outlook.Application
    Set oNameSpace = OL.GetNamespace("MAPI")
    Set oFolder = oNameSpace.GetFolderFromID("Insert the ID")

For i = 2 to r
    Dim appt as MailItem
    Set appt = oFolder.Items.Add(olAppointmentItem)
    With appt
        .Subject = ES.Cells(i,1).Value
        .Start = ES.Cells(i,2).Value
        .End = ES.Cells(i,3).Value
        .Location = ES.Cells(i,4).Value
        .AllDayEvent = ES.Cells(i,5).Value
        .Categories = ES.Cells(i,6).Value & " Category"
        .Save
    End With
Next i

Set OL = Nothing

End Sub
person cbasah    schedule 20.12.2017
comment
Dim appt как Outlook.AppointmentItem вместо MailItem было исправлением! Благодарю вас! Я много исследовал, но не мог закончить, пока не начал работать с вашим дополнением. - person JustinShotMe; 20.12.2017

arrow_upward
0
arrow_downward

Dim appt as Outlook.AppointmentItem был для меня исправлением!

Sub ExportToOutlook2()

    Dim OL As Outlook.Application, ES As Worksheet, _
    r As Long, i As Long, WB As ThisWorkbook, oFolder As Object, oNameSpace As Namespace

    Set WB = ThisWorkbook
    Set ES = WB.Sheets("Export Sheet")
    r = ES.Cells(Rows.count, 1).End(xlUp).Row
    Set OL = New Outlook.Application
    Set oNameSpace = OL.GetNamespace("MAPI")
    Set oFolder = oNameSpace.GetFolderFromID("00000000579E67EAD9C2C94591E62A3CF21135F801001241364BFDA9AF49A3D3384A976997C50036FCD700060000")

    For i = 2 To r
        Dim appt As Outlook.AppointmentItem
        Set appt = oFolder.Items.Add(olAppointmentItem)
        With appt
            .Subject = ES.Cells(i, 1).Value
            .Start = ES.Cells(i, 2).Value
            .End = ES.Cells(i, 3).Value
            .Location = ES.Cells(i, 4).Value
            .AllDayEvent = ES.Cells(i, 5).Value
            .Categories = ES.Cells(i, 6).Value
            .Save
        End With
    Next i

    Set OL = Nothing

    End Sub
person JustinShotMe    schedule 20.12.2017