Function getDefaultFolderFromUser(user, dossier As Outlook.OlDefaultFolders) As Outlook.MAPIFolder

    Dim OLApp As Outlook.Application
    If Application.Name = "Outlook" Then
        Set OLApp = Application
    Else
        Set OLApp = CreateObject("outlook.application")
    End If
    Dim nsOutlook As Outlook.Namespace
    Dim oRecipient As Outlook.Recipient
    Dim Fld As Outlook.MAPIFolder
 
    Set nsOutlook = OLApp.GetNamespace("MAPI")
    Set oRecipient = nsOutlook.CreateRecipient(user)
    oRecipient.Resolve
 
    If oRecipient.Resolved Then
        On Error Resume Next
        Set Fld = nsOutlook.GetSharedDefaultFolder(oRecipient, dossier)
        Set getDefaultFolderFromUser = Fld
        If Err Then Set getDefaultFolderFromUser = Nothing
    Else
        MsgBox user & vbCr & "User inconnu", vbCritical, "Inconnu"
    End If
End Function
Sub NouveauRDV_Calendrier()

Dim OkApp As New Outlook.Application
Dim Rdv As Outlook.AppointmentItem
Dim Fld As Outlook.MAPIFolder

    
    
For i = 7 To Cells(Rows.Count, 12).End(xlUp).Row


Set Fld = getDefaultFolderFromUser("compte2@compte2.com", olFolderCalendar)
Set Rdv = OkApp.CreateItem(olAppointmentItem)
    If Not Fld Is Nothing Then
        MsgBox Fld.Name & vbCr & Fld.FullFolderPath
    End If
With Rdv
    .MeetingStatus = olMeeting
    .Subject = "Relance commande " + Cells(i, 1).Value
    .Body = "Supplier : " & Cells(i, 3).Value & Chr(13) & "Mail : " & Cells(i, 4).Value & Chr(13) & "Phone : " & Cells(i, 5).Value & Chr(13) & "Description : " & Cells(i, 6).Value & Chr(13) & "PN : " & Cells(i, 7).Value & Chr(13) & "QTY : " & Cells(i, 10).Value & Chr(13) & Chr(13) & "Order Date : " & Cells(i, 2).Value & Chr(13) & "Date PN Requested : " & Cells(i, 12).Value & Chr(13) & "Project Deadline : " & Cells(i, 11).Value & Chr(13) & "Acknowledgementof Receipt : " & Cells(i, 13).Value
    .Location = "Supplier : " & Cells(i, 3).Value
    .Start = Range("l" & i).Value - 7 & " 09:00"
    .Duration = 30 'minutes
    .Save
End With

Next

Set OkApp = Nothing

End Sub