1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67
|
Option Explicit
Sub AjoutRV()
Dim DLig As Long, Lig As Long
Dim OutObj As Outlook.Application
Dim OutAppt As Outlook.AppointmentItem
Dim DateRdv As Date, FlgRdv As Boolean
Dim MyCalendar As Outlook.Items
Dim OutlMapi As Outlook.Namespace
Dim OutlFolder As Outlook.MAPIFolder
Dim MyItem As Outlook.AppointmentItem
Dim myNamespace As Outlook.Namespace
Dim myOlApp As New Outlook.Application
Dim MyFolder As Outlook.Items
Dim objOutlook As New Outlook.Application
' Créer une instance d'Outlook
Set OutObj = CreateObject("outlook.application")
' Avec la feuille
With Sheets("Suivi")
DLig = .Range("A" & Rows.Count).End(xlUp).Row
' Pour chaque ligne
For Lig = 12 To DLig
' Vérifier si pas déjà fait
If .Range("D" & Lig) <> "" Then
Else
FlgRdv = True
End If
' Si le FLAG est à vrai on créé le RDV
If FlgRdv Then
'création du rdv
Dim olns As Outlook.Namespace
Dim MyCalendarFolder As Outlook.MAPIFolder
'initialisation du NameSpace
Set olns = objOutlook.GetNamespace("MAPI")
'choix du calendrier
Set MyCalendarFolder = olns.Folders("nicolas.****@cegetel.net").Folders("test")
Set OutAppt = OutObj.CreateItem(olAppointmentItem)
DateRdv = Range("B" & Lig) 'date du rdv, ici prend la colonne B
Set OutAppt = OutObj.CreateItem(olAppointmentItem)
With OutAppt
.Subject = "Maintenance " & Sheets("Suivi").Range("A" & Lig) & " pour le suivi " & Sheets("Suivi").Range("C" & Lig) 'sujet du rdv
.Start = DateRdv & " 08:00 " 'Début du rendez-vous
.Duration = 60 'durée en minute du rdv
.Body = Range("F" & Lig)
.ReminderSet = True 'présence ou non d'un rappel (True/False)
.Save
End With
' Créer le commentaire et inscrire Oui
On Error Resume Next
.Range("D" & Lig) = "Rdv créé"
On Error GoTo 0
End If
Next Lig
End With
Set OutAppt = Nothing
Set MyCalendarFolder = Nothing
Set olns = Nothing
Set objOutlook = Nothing
End Sub |
Partager