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 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113
|
Sub essai_macro_5()
Dim DLig As Long, Lig As Long
Dim DateRdv As Date, FlgRdv As Boolean
Dim OutObj As Outlook.Application
Dim OutAppt As Outlook.AppointmentItem
Dim MyCalendar As Outlook.Items
Dim NS As Outlook.Namespace
Dim objOwner As Outlook.Recipient
'Dim OL As Outlook.Application
Dim olns As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim myFolder As Outlook.Folder
Dim objExpCal As Outlook.Explorer
Dim objNavMod As Outlook.CalendarModule
Dim objNavGroup As Outlook.NavigationGroup
Dim objNavFolder As Outlook.NavigationFolder
Dim objAppt As AppointmentItem
Dim OL As Object
Dim OLmail As Object
Set OLk_Appli = CreateObject("Outlook.Application")
If OLk_Appli.Explorers.Count > 0 Then
'Ok outlook ouvert
Else
'mettre le bon chemin outlook
OLk_OK = Shell("C:\Program Files (x86)\Microsoft Office\Office15\outlook.exe", vbHide)
End If
Set OL = New Outlook.Application
Set olns = Outlook.Application.Session
Set objExpCal = olns.GetDefaultFolder(olFolderCalendar).GetExplorer
Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
Set objNavGroup = objNavMod.NavigationGroups.GetDefaultNavigationGroup(olPeopleFoldersGroup)
Set objAppt = Outlook.Application.CreateItem(olAppointmentItem)
If olns.DefaultStore.DisplayName = "richard.XXX@XXXXXX.com" Then
'cas où le propriétaire du calendrier partagé fait l'opération
Set myFolder = olns.GetDefaultFolder(olFolderCalendar)
Set Mysubfolder = myFolder.Folders("SRY Tomato Planning").Items
Else
'cas où un autre utilisateur ayant les droits d'éditeur fait l'opération
Set myRecipient = olns.CreateRecipient("richard.XXX@XXXXXX.com")
myRecipient.Resolve
If myRecipient.Resolved Then
Set Mysubfolder = objNavGroup.NavigationFolders("SRY Tomato Planning").Folder.Items
End If
End If
' Avec la feuille
With Sheets("Feuil1")
DLig = .Range("A" & Rows.Count).End(xlUp).Row
' Pour chaque ligne
For Lig = 2 To DLig
' Si une date existe
If .Range("D" & Lig) <> "" Then
' Si un RDV n'a pas déjà été créé
If .Range("K" & Lig) <> "" Then
' Si le commentaire a changé
If .Range("K" & Lig).Comment.Text <> .Range("H" & Lig).Value Then
FlgRdv = False
Else
' Sinon le commentaire n'a pas changé = pas de RDV
FlgRdv = False
End If
Else
' Sinon, pas de RDV déjà créé
FlgRdv = True
End If
Else
' Sinon, pas de date d'évènement
FlgRdv = False
End If
' Si le FLAG est à vrai on créé le RDV
If FlgRdv Then
DateRdv = Range("D" & Lig)
'Set OutAppt = MyCalendar.Add
'With OutAppt
Set OutAppt = Mysubfolder.Add
With OutAppt
.MeetingStatus = olMeeting
.Subject = Range("E" & Lig) & " - " & Range("F" & Lig) & " - " & Range("B" & Lig) & " - " & Range("D" & Lig)
.Start = Range("D" & Lig) & " 06:00"
.Duration = 60
.ReminderSet = True
.ReminderMinutesBeforeStart = 60 * 24 * Range("I" & Lig)
.Categories = Range("C" & Lig)
.Location = Range("G" & Lig)
.Body = Range("H" & Lig)
.RequiredAttendees = Range("J" & Lig)
.Send
.Save
End With
' Créer le commentaire et inscrire Oui
On Error Resume Next
.Range("K" & Lig).Comment.Delete
.Range("K" & Lig).AddComment
.Range("K" & Lig).Comment.Text Text:=Range("H" & Lig).Value '& Chr(10) & Format(Date, "dd mmmm yyyy")
.Range("K" & Lig) = "Oui"
On Error GoTo 0
End If
Next Lig
End With
Set OutAppt = Nothing
End Sub |
Partager