Gestione Calendar Outlook tramite Excel

Hai un problema con Excel?

Nuova discussione

Gestione Calendar Outlook tramite Excel
di M4RR7 (utente non iscritto) data: 14/06/2017 09:49:36
Ciao a tutti,
Vorrei sottoporre a voi un argomento particolare, quello della gestione appuntamenti outlook mediante dati in excel.

In uno sheet "Elenco Scadenze" ho una tabella a 3 colonne:
TIPODOCUMENTO
NOTEDOCUMENTO
DATASCADENZA

lanciando la macro aggiornaScadenze carico tutta la tabella in una matrice e successivamente per ogni rigo creo un calendar:
La data del calendar è DATASCADENZA
L'oggetto è TIPODOCUMENTO
Il testo è NOTEDOCUMENTO

Vorrei implementare la macro con due altre funzionalità:

1) spedire il calendar ad una lista di indirizzi email

2) sviluppare un codice che esegua una verifica in maniera tale che ogni qualvolta si va creare un calendar, se ne esiste già uno in outlook con lo stesso oggetto, si verifichi se data e testo sono stati aggiornati, nel caso aggiornarlo su outlook e inviare l'aggiornamento ai contatti email della lista di cui sopra.

Come posso fare?

Allego il codice che ho finora prodotto.
Se qualcuno può aiutarmi lo ringrazio davvero.

Option Explicit
Option Base 1

'matrice elenco scadenze
Public elencoScadenze()
'stabilisce il numero di tuple della matrice
Public righeSCADelenco As Integer

Sub aggiornaScadenze()
    
    Dim i As Integer
    
    Sheets("Elenco Scadenze").Select
    
    'valuta la lunghezza della matrice scadenze in relazione alle righe della tabella
    i = 1
    Do While Range(Cells(i, 1), Cells(i, 1)).Value <> ""
        i = i + 1
    Loop
    righeSCADelenco = i - 2
    
    If righeSCADelenco > 0 Then
    
        'formatta la dimensione della matrice in base al numero di righe della tabella
        ReDim elencoScadenze(righeSCADelenco, 3)
        
        'riempie la matrice
        For i = 1 To righeSCADelenco
            elencoScadenze(i, 1) = Range(Cells(i + 1, 1), Cells(i + 1, 1)).Value 'colonna TIPODOCUMENTO
            elencoScadenze(i, 2) = Range(Cells(i + 1, 2), Cells(i + 1, 2)).Value 'colonna NOTEDOCUMENTO
            elencoScadenze(i, 3) = Range(Cells(i + 1, 3), Cells(i + 1, 3)).Value 'colonna DATASCADENZA
        Next i
        
        'richiama la funzione letturaScadenze che leggerà i dati contenuti nella matrice
        Call letturaScadenze
        
    Else
        MsgBox ("Non Vi sono scadenze da pianificare")
    End If
End Sub

Sub letturaScadenze()
    
    Dim i As Integer
    'per ciascun documento presente nella lista richiama la funzione creaCalendar
    For i = 1 To righeSCADelenco
        Call creaCalendar(elencoScadenze(i, 1), elencoScadenze(i, 2), elencoScadenze(i, 3))
    Next i

End Sub

Sub creaCalendar(tipoDocumento, noteDocumento, dataScadenza)

    'verifica che il documento in analisi abbia una data scadenza
    If IsNull(dataScadenza) Then
        MsgBox "il documento " & tipoDocumento & " non ha una data scadenza", vbInformation, "campo obbligatorio"
        Exit Sub
    End If
    
    Dim OutApp As Object
    Dim OutCalendar As Object
    Dim outCalendarFolder As Object
    Dim targetCalendar As Object
    
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    
    'creare un nuovo appuntamento
    Set OutCalendar = OutApp.CreateItem(1)
    ' 1 sta per appuntamento
    
    OutCalendar.AllDayEvent = True
    OutCalendar.Start = dataScadenza
    OutCalendar.Subject = tipoDocumento
    OutCalendar.Body = noteDocumento
    OutCalendar.ReminderMinutesBeforeStart = 50
    OutCalendar.ReminderSet = True
    OutCalendar.Save
    
    'chiude lo stream con Outlook
    Set OutApp = Nothing
    Set OutCalendar = Nothing
    
End Sub

di Vecchio Frac data: 14/06/2017 11:16:34
Riesci ad allegare materialmente un piccolo file con dati di esempio?
Il codice lo hai scritto tu? Vedo possibili alcune semplificazioni e vedo anche che non sei poi così lontano dalla soluzione (crei un oggetto MailItem nello stesso modo dell'oggetto Appuntamento e ne imposti la lista destinatari nel campo .To; controlli la lista degli appuntamenti filtrando per oggetto e fai le opportune verifiche).
di M4RR7 (utente non iscritto) data: 14/06/2017 11:44:37
Grazie per l'attenzione Vecchio Frac,

Ho provato ad allegare un file mediante l'apposito pulsante in cima alla discussione.
Ho afferrato solo in parte la tua risposta, perdonami se ti chiedo chiarimenti..

Nello specifico:

1) Se posso scrivere una cosa del tipo:

OutCalendar.to="tizio@gmail.com"

2) Se creo un nuovo oggetto MailItem nello stesso modo in cui ho creato un nuovo appuntamento non mi crea un'altro appuntamento?

MailItem = OutApp.CreateItem(1)

Inoltre come faccio a filtrare?
di Vecchio Frac data: 14/06/2017 11:55:17
Rispondo rapidamente (ora ho altro lavoro che mi aspetta):
1) premesso che devi riferirti a un oggetto mail e non a un oggetto Calendario, puoi separare più indirizzi con punto e virgola, esattamente come faresti in Outlook: MailItem.To = "tizio@gmail.com; caio@gmail.com; sempronio@libero.it"

2) l'oggetto MailItem è rappresentato da una costante diversa (1 = olAppointmentItem, 0 = olMailItem) quindi l'istruzione corretta è MailItem = OutApp.CreateItem(0)

A filtrare i dati ci pensi dopo... risolvi prima il problema di creare un oggetto mail correttamente :)
Suggerimento: apri Outlook e guarda come funziona il suo modello di MailItem.
Quindi apri Outlook, Alt-F11, F2 per l'object viewer, scrivi MailItem nella casella di ricerca e studiati i metodi della classe MailItem (non puoi sbagliare).
di M4RR7 (utente non iscritto) data: 14/06/2017 12:58:22
Grazie ancora Vecchio Frac per il tempo che mi stai dedicando, non avevo bene afferrato la tua prima risposta e dopo il tuo chiarimento ho capito cosa intendevi.
Ok sul creare l'oggetto mail ci sono, in realtà sapevo farlo, ma non è la soluzione che cerco. Ho esposto male il problema in effetti, cerco di essere più preciso.

In sostanza vorrei modificare il codice sopra in maniera tale

1) Da invitare partecipanti al calendar (non di allegare il calendar per e-mail a dei destinatari)
Ho cercato su msdn microsoft com tra i metodi gli eventi e gli attributi di AppointmentItem Object ma non riesco a trovare nulla che faccia riferimento ai partecipanti.

2) In qualche modo consultare ciascun calendar che ho in outlook e, se incontro quello con l'oggetto uguale, verificare se corpo e data sono cambiati, nel caso sostituirli.

di Vecchio Frac data: 14/06/2017 14:04:05
Ok ho capito adesso :) e il tuo codice funziona bene.
1) Ho fatto una prova in finestra immediata. L'insieme dei partecipanti è come quello dei destinatari di una mail normale: Recipients. Col metodo .Add aggiungi quelli che ti servono. Con .Send invii l'invito (non ho provato!)

Una cosa così, per restare nel tuo esempio:
outcalendar.recipients.add ("tizio@example.com; caio@example.com")
outcalendar.send

2) Ti scrivo uno scheletro di codice che ho realizzato altrove; tieni conto che gli oggetti che seguono, tu magari li hai già:


 Set objApp = CreateObject("Outlook.Application")

 Set NameSpace = objApp.GetNamespace("MAPI")

 Set fdrCalendar = NameSpace.GetDefaultFolder(9)                                     '9 = olFolderCalendar



     For Each ItemAppt In fdrCalendar.Items                                                       'use this line instead to consider ALL dates from Outlook

'    For Each ItemAppt In fdrCalendar.items.Restrict("[Start] >= '01/01/2017'")        'consider dates from 1-1-2017 onwards from Outlook

     

     'ora qui ciclare per tutti gli item di cui controllare il subject

     'tipo: for each v in excel_table 

     '   if itemappt.subject = v[colonna::tipodocumento] Then 

     '        'trovato subject uguale: verifico se il corpo è uguale, se diverso lo aggiorno

     '        if itemappt.body <> v[colonna::notedocumento]  then itemappt.body = v[colonna::notedocumento]

     ' problema per la data di scadenza disuguale:

     '        if itemappt.start <> v[colonna::datascadenza]  then ... ' ecco questo è il punto, la data di scadenza non coincide con l'appuntamento. va eliminato e ricostruito nella data corretta. Sicuro che è questa la verifica che vuoi fare?

     '  end if

     'next



    next

di Vecchio Frac data: 14/06/2017 14:17:31
Comunque tutto il tuo codice io lo ottimizzerei un pochino.
Tutto quello che hai scritto va bene ma può essere ridotto in una sola sub.

Sub aggiornaScadenze_VF()
Dim v As Variant
Dim OutApp As Object
Dim OutCalendar As Object
Dim i As Long
    
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    
    'creare un nuovo appuntamento
    Set OutCalendar = OutApp.CreateItem(1)
    ' 1 sta per appuntamento

    Sheets("Elenco Scadenze").Select
    For Each v In Range("A1").CurrentRegion.Rows
        If v.Row > 1 Then
            If Trim(v.Cells(3)) = "" Then
                MsgBox "il documento " & v.Cells(1) & " non ha una data scadenza", vbInformation, "campo obbligatorio"
                Exit Sub
            End If
            
            With OutCalendar
                .AllDayEvent = True
                .Start = v.Cells(3)         'data scadenza
                .Subject = v.Cells(1)       'tipo documento
                .Body = v.Cells(2)          'note documento
                .ReminderMinutesBeforeStart = 50
                .ReminderSet = True
                .Save
            End With
            
            i = i + 1
        End If
    Next
    
    'chiude lo stream con Outlook
    Set OutCalendar = Nothing
    Set OutApp = Nothing
    
    MsgBox "Ho inserito " & i & "scadenze"
End Sub

di M4RR7 (utente non iscritto) data: 14/06/2017 18:25:12
Allora innanzitutto il codice così è senz'altro più bello e più snello oltre che più professionale, e si vede qui la differenza con una mezzacalzetta quale sono io.
Non ho ben chiara la storia dei currentregionrows eccetera eccetera, comunque ho modificato il tuo codice con la sezione relativa ai partecipanti e l'ho provato ma a quanto pare ci sono dei problemi:

- Viene creato solo un calendar (solo quello ultimo in tabella)

- In caso una riga non presenta il campo data popolato, viene creato sempre e solo un calendar ossia quello relativo alla riga precedente a quella senza il campo popolato. Pare che la formula si fermi li e non continua a valutare le righe successive, cosa che con la sub esterna come avevo previsto io però funzionava. Non saprei come modificare il codice che hai scritto tu perchè, come ti dicevo, non l'ho capito molto bene.

- In caso di aggiornamento della data la formula crea un altro calendar e non sostituisce quello precedente

- La parte relativa alla storia dei partecipanti non funziona, e aggiungo una curiosità:
ho provato a sostituire .send con .display e togliere .save RISULTATO, mi si apre il calendar senza la sezione "partecipanti", manualmente vado ad inserire i partecipanti mediante il menù apposito della finestra outlook e tadaaa: mi viene riportata la lista degli indirizzi ripetuti per tante volte quante sono le righe prima della data mancante (o se le date ci sono tutte, prima della fine della tabella)

Ok sto impazzendo dietro a questo problema, pare che sia una roba più tosta di quella che pensassi.
Ale

Sub aggiornaScadenze_VF()
Dim v As Variant
Dim OutApp As Object
Dim OutCalendar As Object
Dim i As Long
    
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    
    'creare un nuovo appuntamento
    Set OutCalendar = OutApp.CreateItem(1)
    ' 1 sta per appuntamento

    Sheets("Elenco Scadenze").Select
    For Each v In Range("A1").CurrentRegion.Rows
        If v.Row > 1 Then
            If Trim(v.Cells(3)) = "" Then
                MsgBox "il documento " & v.Cells(1) & " non ha una data scadenza", vbInformation, "campo obbligatorio"
                Exit Sub
            End If
            
            With OutCalendar
                .AllDayEvent = True
                .Start = v.Cells(3)         'data scadenza
                .Subject = v.Cells(1)       'tipo documento
                .Body = v.Cells(2)          'note documento
                .ReminderMinutesBeforeStart = 50
                .ReminderSet = True
                .Recipients.Add ("tizio@prova.it;caio@prova.it")
                .Save
                .Send
            End With
            
            i = i + 1
        End If
    Next
    
    Set OutCalendar = Nothing
    Set OutApp = Nothing
    
    MsgBox "Ho inserito " & i & " scadenze"
End Sub

di Vecchio Frac data: 15/06/2017 09:39:15
Ok, i primi due punti sono facilmente risolvibili.

In caso di aggiornamento di una data di scadenza: gli appuntamenti già inseriti non devono essere duplicati e l'appuntamento modificato deve essere rimosso dalla data originale e spostato alla nuova data, corretto?

Sui partecipanti: vediamo :)

di M4RR7 (utente non iscritto) data: 15/06/2017 09:53:01
Dunque ci sono, mi sono sbattuto un po' e sono riuscito ad andare avanti unendo insieme tutti i tuoi suggerimenti.
Sono riuscito a tirar fuori questo.

Risolto la storia dei duplicati, unico problema è il confronto con il body che ho dovuto disattivare, per lui anche se c'è lo stesso valore quando li confronta sono sempre diversi.

ho provato ad analizzare la cosa a fondo con dei Msgbox "spia"
MsgBox(Itemappt.Body & " - " & v.Cells(2))
MsgBox Len(Itemappt.Body)

Pare che nel body vada a capo e aggiunga 3 caratteri in più (invisibili)

Per il resto tutto ora funziona ma non va la storia dei partecipanti.

Sub aggiornaScadenze_VF()
    
    Dim v As Variant
    Dim OutApp As Object
    Dim OutCalendar As Object
    
    'n contatore nuovi appuntamenti
    'm contatore appuntamenti modificati
    Dim n, m As Long
    
    'variabili di verifica sui calendar esistenti
    Dim itemExist, itemModified As Boolean
    
    Set OutApp = CreateObject("Outlook.Application")
    Set Namespace = OutApp.GetNamespace("MAPI")
    Set fdrCalendar = Namespace.GetDefaultFolder(9)
    
    OutApp.Session.Logon
    Sheets("Elenco Scadenze").Select
    
    n = 0
    m = 0
    
    For Each v In Range("A1").CurrentRegion.Rows
        If v.Row > 1 Then
            esistente = False
            If Trim(v.Cells(3)) = "" Then
                MsgBox "il documento " & v.Cells(1) & " non ha una data scadenza", vbInformation, "campo obbligatorio"
            Else
                For Each Itemappt In fdrCalendar.Items
                    If Itemappt.Subject = v.Cells(1) Then
                        'trovato subject uguale
                        'verifico se data e tipo documento sono uguali, se diversi li aggiorno
                        
                        If Itemappt.Start <> v.Cells(3) Then
                            Itemappt.Start = v.Cells(3)
                            itemModified = True
                        End If
                        
                        'If Itemappt.Body <> (v.Cells(2) & vbCrLf) Then
                        ' MsgBox(Itemappt.Body & " - " & v.Cells(2))
                        '    MsgBox Len(Itemappt.Body)
                        '    Itemappt.Body = v.Cells(2)
                        '    itemModified = True
                        'End If
                        
                        Itemappt.Send
                        Itemappt.Save
                        
                        itemExist = True
                        If itemModified = True Then
                            m = m + 1
                        End If
                    End If
                Next
                If itemExist = False Then
                    
                    'creare un nuovo appuntamento
                    Set OutCalendar = OutApp.CreateItem(1)
    
                    With OutCalendar
                        .AllDayEvent = True
                        .Start = v.Cells(3)         'data scadenza
                        .Subject = v.Cells(1)       'tipo documento
                        .Body = v.Cells(2)          'note documento
                        .ReminderMinutesBeforeStart = 50
                        .ReminderSet = True
                        .Recipients.Add ("tizio@prova.it;caio@prova.it")
                        .Send
                        .Save
                    End With
                    test = True
                    n = n + 1
                End If
            End If
        End If
    Next
    
    Set OutCalendar = Nothing
    Set OutApp = Nothing
    
    MsgBox "VERIFICA APPUNTAMENTI TERMINATA:" & vbCrLf & "Nuove scadenze inserite: " & n & vbCrLf & "Scadenze aggiornate: " & m

End Sub

di Vecchio Frac data: 15/06/2017 10:00:40
Mi hai un po' preceduto.
Vediamo se comunque è utile se ti allego (per prova) questa versione.
Devo ancora risolvere il problema dei destinatari.

di Vecchio Frac data: 15/06/2017 10:00:55
Allego il codice.

Option Explicit

Sub aggiornaScadenze_VF()
Dim v As Variant
Dim OutApp As Object
Dim fdrCalendar As Object
Dim ItemAppt As Object
Dim i As Long, j As Long
Dim bFound As Boolean
    
    Set OutApp = CreateObject("Outlook.Application")
    Set fdrCalendar = OutApp.GetNamespace("MAPI").GetDefaultFolder(9)    '9 = olFolderCalendar

    OutApp.Session.Logon

    Sheets("Elenco Scadenze").Select
    For Each v In Range("A1").CurrentRegion.Rows
        If v.Row > 1 Then
            If Trim(v.Cells(3)) = "" Then
                MsgBox "il documento " & v.Cells(1) & " non ha una data scadenza", vbInformation, "campo obbligatorio"
            Else
                '---- check
                For Each ItemAppt In fdrCalendar.Items
                    If ItemAppt.Subject = v.Cells(1) Then
                        bFound = True
                        'trovato subject uguale: verifico se il corpo è uguale, se diverso lo aggiorno
                        If ItemAppt.Body <> v.Cells(2) Then ItemAppt.Body = v.Cells(2)
        
                        'data di scadenza non uguale all'appuntamento già inserito:
                        'cancella appuntamento esistente e lo reinserisce in nuova posizione
                        If ItemAppt.Start <> v.Cells(3) Then
                            ItemAppt.Delete
                            Call CreateItem(OutApp, v)
                            j = j + 1
                        End If
                    End If
                Next
                '--------------------
                If Not bFound Then
                    Call CreateItem(OutApp, v)
                    i = i + 1
                    bFound = False
                End If
            End If
        End If
    Next
    
    Set OutApp = Nothing
    
    MsgBox "Ho inserito " & i & " scadenze, ho modificato " & j & " scadenze"
End Sub


Private Sub CreateItem(olApp As Object, v As Variant)
Dim OutCalendar As Object
    Set OutCalendar = olApp.CreateItem(1)  'nuovo appuntamento
    With OutCalendar
        .AllDayEvent = True
        .Start = v.Cells(3)         'data scadenza
        .Subject = v.Cells(1)       'tipo documento
        .Body = v.Cells(2)          'note documento
        .ReminderMinutesBeforeStart = 50
        .ReminderSet = True
        .Recipients.Add ("tizio@prova.it;caio@prova.it")
        .Save
        '.Send
    End With
    Set OutCalendar = Nothing
End Sub

di Vecchio Frac data: 15/06/2017 10:25:11
Avevo il mio problema del salvataggio della modifica del Body (non ho riscontrato il problema che lamenti tu, però).
La modifica al mio codice è la seguente:

                        'trovato subject uguale: verifico se il corpo è uguale, se diverso lo aggiorno
                        If ItemAppt.Body <> v.Cells(2) Then
                            ItemAppt.Body = v.Cells(2)
                            ItemAppt.Save
                            j = j + 1
                        End If

di Vecchio Frac data: 15/06/2017 10:27:04
cit. "Pare che nel body vada a capo e aggiunga 3 caratteri in più (invisibili) "
---> Questa cosa non la sto verificando. Forse sono i dati di partenza a essere diversi (ho tenuto l'esempio originale). vbCrLf? mi pare strano

di Vecchio Frac data: 15/06/2017 11:00:52
Un passo avanti che posso proporre è impostare lo "stato della riunione" a 1 (olMeeting).
Tuttavia si blocca su .Send con "oggetto non trovato" se il destinatario non viene trovato (esempio tizio@prova.it). Andrebbe gestita la situazione con On Error.

    With OutCalendar
        .AllDayEvent = True
        .Start = v.Cells(3)         'data scadenza
        .Subject = v.Cells(1)       'tipo documento
        .Body = v.Cells(2)          'note documento
        .ReminderMinutesBeforeStart = 50
        .ReminderSet = True
        .Recipients.Add ("tizio@prova.it;caio@prova.it")
        .MeetingStatus = 1      ' 1 = olMeeting
        .Recipients.ResolveAll
        .Send
        .Save
    End With

di M4RR7 (utente non iscritto) data: 15/06/2017 11:55:58
cit "vbCrLf? mi pare strano" --> era solo una prova, mi son dimenticato di togierla

Ho provato con le modifiche tue ma niente mi sa che sul controllo del Body in quell' "if" non riesco a capire per che ma ci entra sempre

".MeetingStatus = 1 ' 1 = olMeeting"
Ottima idea, in effetti ora si attiva il campo Meeting già popolato con i partecipanti, si blocca però su Send come dicevi tu, e lo fa anche con indirizzi reali.
Ho provato semplicemente con "On Error Resume Next" ma ovviamente siamo lì, non invia il calendar.

In ogni caso grazie Vecchio Frac sei già diventato l'idolo del nostro ufficio
di Vecchio Frac data: 15/06/2017 12:17:37
cit. " e lo fa anche con indirizzi reali. "
---> Eh no questo no :) ho inserito un mio indirizzo personale e funziona perfettamente ^_^

Per il controllo sulla cella (a me non capita il tuo caso) prova a trimmare gli spazi.

If ItemAppt.Body <> trim(v.Cells(2)) Then ...

Su che versione di Excel stai lavorando?
di M4RR7 (utente non iscritto) data: 15/06/2017 12:48:04
OK l'invio funziona onestamente non ho capio perchè non me lo inviava prima!!
Inutile dirti super grazie,
Rimane la storia del body.. il trim non sembra funzionare

l'ho provato in tutti e tre i modi possibili:
così come dicevi tu
If ItemAppt.Body <> trim(v.Cells(2)) Then ...
al contrario
If trim(ItemAppt.Body) <> v.Cells(2) Then ...
ad entrambi
If trim(ItemAppt.Body) <> trim(v.Cells(2)) Then ...

Nulla da fare.
La versione EXCEL è la 2006, dovrebbe cambiare qualcosa?
di Vecchio Frac data: 15/06/2017 14:05:45
La versione "Excel 2006" è la prima che incontro :)
Forse 2007? Se in Immediata digiti "?application.version" (invio) cosa ti vien fuori?

Torniamo al test che hai fatto, che è interessante:
MsgBox(Itemappt.Body & " - " & v.Cells(2))
MsgBox Len(Itemappt.Body)

Metti un breakpoint dopo "If ItemAppt.Body <> v.Cells(2) Then" così si ferma quando trova un valore disuguale. In Immediata fai
```
?Itemappt.Body & " - " & Len(Itemappt.body) & vbcrlf & v.Cells(2) & " - " & len(v.cells(2)) 
```
e vediamo il risultato.
Abbiamo forse dati diversi di origine?
di Vecchio Frac data: 15/06/2017 14:10:36
Penso che alla fine ti suggerirò di utilizzare .Clean che elimina da una stringa i caratteri non stampabili (codici ASCII da 0 a 31):
If ItemAppt.Body <> trim(worksheetfunction.Clean(v.Cells(2))) Then ...
di M4RR7 (utente non iscritto) data: 15/06/2017 15:45:22
Vecchio Frac hai risolto tutto,

Con .Clean il problema non si ripresenta.
Il fatto è che doveva essere applicato al primo elemento (Body), era quello il problema.

Ottimo lavoro!
di Vecchio Frac data: 15/06/2017 15:49:55
Tutto è migliorabile

Vuoi Approfondire?