Aggiungere Promemoria a calendario di gruppo Outlook

Dim ns
Dim OutObj  ' Riferimento ad Outlook
Dim OutAppt ' Appuntamento da aggiungere
Dim objOwner 'Proprietario casella
Dim MiaCartellaNew
Dim MiaCartellaDefault
Set OutObj = CreateObject("Outlook.Application") ' Late binding

'------------------------ Selezione cartella calendario a cui aggiungere ---------------------------
Set ns = OutObj.GetNamespace("MAPI") 'Attivo protocollo MAPI

'--------------Per poter aggiungere ad un calendario proprietario--------------------
Set MiaCartellaDefault = ns.GetDefaultFolder(9) '9= olFolderCalendar    'Portarsi e Usare cartella di default

'------------------------ Creazione Appuntamento e Invio ad Outlook --------------------------------
Set OutAppt = MiaCartellaDefault.Items.Add(1)   ' 1= olAppointmentItem  'Specifico dove aggiungere l'appuntamento

With OutAppt
.Start = Date & " " & "8:00:00 AM"
.End = Date & " " & "11:00:00 AM"
'.Duration = txtDurataEvento
.Subject = "Prova Subject"    'TitoloEvento
.Body = "Prova Body" 'DescrizioneEvento
.Location = "Prova Location"          'SedeEvento
'.Recipients.Add ("UTENTE")
.ReminderMinutesBeforeStart = 15
.ReminderSet = True
.Save   ' Salvo i dati
.Send   ' Li invio ad Outlook
End With

Set OutAppt = Nothing
Set OutObj = Nothing
Set ns = Nothing

MsgBox "Promemoria aggiunto"

Dim ns
Dim OutObj  ' Riferimento ad Outlook
Dim OutAppt ' Appuntamento da aggiungere
Dim objOwner 'Proprietario casella
Dim MiaCartellaCodivisa

Set OutObj = CreateObject("Outlook.Application") ' Late binding

'------------------------ Selezione cartella calendario a cui aggiungere ---------------------------
Set ns = OutObj.GetNamespace("MAPI") 'Attivo protocollo MAPI


'----------- Per poter aggiungere ad un calendario condiviso exchange (devo avere i permesi di scrittura)
Set objOwner = ns.CreateRecipient("Proprietario cartella da raggiungere")
    objOwner.Resolve

If objOwner.Resolved Then
   'MsgBox objOwner.Name
 Set MiaCartellaCodivisa = ns.GetSharedDefaultFolder(objOwner, 9) 'olFolderCalendar
End If

'------------------------ Creazione Appuntamento e Invio ad Outlook --------------------------------
Set OutAppt = MiaCartellaCodivisa.Items.Add(1)   ' 1= olAppointmentItem  'Specifico dove aggiungere l'appuntamento

With OutAppt
.Start = Date & " " & "8:00:00 AM"  'Data inizio
.End = Date & " " & "11:00:00 AM"   'Data Fine
'.Duration = txtDurataEvento
.Subject = "Prova Subject"          'TitoloEvento
.Body = "Prova Body"                'DescrizioneEvento
.Location = "Prova Location"        'SedeEvento
'.Recipients.Add ("UTENTE")
.ReminderMinutesBeforeStart = 15
.ReminderSet = True
.Save                               'Salvo i dati
.Send                               'Li invio ad Outlook
End With

Set OutAppt = Nothing
Set OutObj = Nothing
Set ns = Nothing

MsgBox "Promemoria aggiunto"