Calendario Outlook con Excel

Question

Ciao,

premesso non sono esperta, mi hanno chiesto di gestire un calendario di una casella condivisa in exchange per poter inserire/modificare/cancellare i vari appuntamenti da un foglio excel (Una Tabella), in internet ho trovato una soluzione in VBA, questa funziona quasi completamente perché quando aggiungo una nuova riga questa non viene aggiunta, non riesco trovare l'errore e il motivo del blocco

allego il file

Esempio

Grazie a tutti

Answer 1

Buongiorno Laura,

Ma questa funzione l'hai presa da qualche parte ed era compresa di file di esempio?

L'hai scritta tu? L'hai modificata?

Il file originale e' uguale a questo di prova che ci hai inviato?

Answer 2

Ciao Daniele,

in questo modo la situazione è peggiorata perché:

in Outlook viene caricato solo la prima riga (anche mettendo tutte la date in Excel) 

ora nel messaggio "il documento …. che non ha scadenza" prende il valore della data anche se sono inserite tutte le date

Grazie

Answer 3

Sembra strano in quanto il range viene caricato bene, prova comunque a sostituire tutto il codice con questo:

(in pratica ho cambiato solo le prime righe prima del ciclo for modifcando il modo in cui il range viene preso)

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
Dim j As Long
Dim bFound As Boolean
Dim rng As Range
Dim lastRow As Integer
    
    Set OutApp = CreateObject("Outlook.Application")
    Set fdrCalendar = OutApp.GetNamespace("MAPI").GetDefaultFolder(9)    '9 = olFolderCalendar

    OutApp.Session.Logon

    Sheets("Foglio1").Select 'Nome del foglio excel
    
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    Set rng = Range("A1:C" & lastRow)
    rng.Select
    
    For Each v In rng
        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)
                            ItemAppt.Save
                            j = j + 1
                        End If
        
                        '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
                        
                        'Data di scadenza è = TDB in excel e all'appuntamento già inserito:
                        'Cancella appuntamento esistente
                        If v.Cells(3) = "TBD" Then
                            ItemAppt.Delete
                            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    'Applica quanti minuti prima deve inviare il Reminder della scadenza
        .ReminderSet = False                'Non applica il Reminder alla scadenza
        '.Recipients.Add ("******@prova.it;******@prova.it")
        .Save
        '.Send
    End With
    Set OutCalendar = Nothing
End Sub

Ho salvato anche il file condiviso, dovresti avere il codice anche li.

E' un tentativo per capire cosa succede, non dovrebbe cambiare molto.

Fammi sapere,

Daniele

Answer 4

Ciao Daniele,

esatto se aggiungo una riga questa non viene elaborata, anche quando cambio il valore TBD questa non viene elaborata

Io non sono esperta e non riesco trovare il problrma

Grazie

Answer 5

Ciao Laura,

ho dato un occhiata al codice in realtá non vedo niente di errato in esso. Vorrei capire cosa intendi per "una nuova riga non viene aggiunta".

Le righe che vengono elaborate sono tutte quelle contenute nella "regione" che inizia con la cella A1, quindi qualsiasi cosa consecutiva ad A1, che non salti alcuna riga, viene elaborata.

Quando dici che quando aggiungi una nuova riga non viene aggiunta ti viene restituito qualche errore?

Saluti,

Daniele