Définir le calendrier pour un rappel outlook

Bonjour,

J'utilise un code vba pour me faire des rappels outlook en fonction de dates saisies dans un onglet. Possédant plusieurs boites mail je voudrais choisir le calendrier approprié dans mon code. Quelqu'un aurait-il une solution ?

Mon code :

Sub rappels()
 Dim I As Long
    Dim xRg As Range
    Dim xOutApp As Object
    Dim xOutItem As Object
    Set xOutApp = CreateObject("Outlook.Application")
    Set xRg = Range("A2:F5")

    For I = 7 To (7 + xRg.Rows.Count)

        Set xOutItem = xOutApp.CreateItem(1)
        Debug.Print xRg.Cells(I, 1).Value
        '------objet-------
        xOutItem.Subject = "Rappel  n°: " & xRg.Cells(I, 3).Value 'xRg.Cells(I, 1).Value
        '------Compare les dates ---------
        If xRg.Cells(I, 15).Value > Date Then

        xOutItem.Location = xRg.Cells(I, 15).Value
        Else
        xOutItem.Location = False
        End If

        xOutItem.Start = xRg.Cells(I, 16).Value
        xOutItem.Duration = 60
        If xRg.Cells(I, 5).Value > 0 Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 60
        Else
        xOutItem.ReminderSet = False
        End If
        xOutItem.Body = "Réponse à faire pour le n°: " & xRg.Cells(I, 3).Value 'xRg.Cells(I, 6).Value"
        xOutItem.Save
        Set xOutItem = Nothing
    Next
    Set xOutApp = Nothing
End Sub

Merci

Bonsoir,

ci-dessous code

Sub rappels()
    Dim I As Long
    Dim xRg As Range
    Dim xOutApp As Object, items_boîte_mail As Object, calendrier As Object, xOutItem As Object
    Const boîte_mail As String = "xxxxxxxxxxx@yyyyyyyyy.zzz"

    Set xOutApp = CreateObject("Outlook.Application")
    Set items_boîte_mail = xOutApp.Session.Folders(boîte_mail)
    Set calendrier = items_boîte_mail.Folders("calendrier")
    Set xRg = Range("A2:F5")

    For I = 7 To (7 + xRg.Rows.Count)

        Set xOutItem = calendrier.Items.Add(1)
        Debug.Print xRg.Cells(I, 1).Value
        '------objet-------
        xOutItem.Subject = "Rappel  n°: " & xRg.Cells(I, 3).Value 'xRg.Cells(I, 1).Value
        '------Compare les dates ---------
        If xRg.Cells(I, 15).Value > Date Then
            xOutItem.Location = xRg.Cells(I, 15).Value
        Else
            xOutItem.Location = False
        End If

        xOutItem.Start = xRg.Cells(I, 16).Value
        xOutItem.Duration = 60
        If xRg.Cells(I, 5).Value > 0 Then
            xOutItem.ReminderSet = True
            xOutItem.ReminderMinutesBeforeStart = 60
        Else
            xOutItem.ReminderSet = False
        End If

        xOutItem.Body = "Réponse à faire pour le n°: " & xRg.Cells(I, 3).Value 'xRg.Cells(I, 6).Value"
        xOutItem.Save
        Set xOutItem = Nothing
    Next I

End Sub

Bonjour,

Merci pour ce code, il correspond tout à fait à ce que j'avais besoin.

Cordialement.