Bonjour tout le monde,
Je viens solliciter votre aide pour corriger un bug dans mon code VBA....
Sur Outlook 2013, je dispose d'un agenda perso... et d'un agenda partagé commun avec mes collègues...
Je souhaite déverser des éléments de mon agenda perso dans l'agenda partagé... du genre les congés, les formations, etc...
Avec mon code, j'arrive à déverser ces éléments... néamoins, seulement 1 seul élément.... Congés... ou Formation... en fonction de ce que je marque comme sujet dans mon code...
J'aimerais créer une fonction "OR"... pour lui dire "si tu vois dans le sujet de l'événement soit le mot CONGES ou FORMATION ou XXX alors tu recopies dans l'agenda partagé"....
Mais rien à faire, cela ne fonctionne pas!!!
Voici ci-dessous mon code... Merci pour votre aide!!!
Sub Copie_événement()
Dim MonSousDoss As Outlook.Folder
Set MonApp = Outlook.Application
Set MonNameSpace = MonApp.GetNamespace("MAPI")
'On pointe sur le calendrier pour chercher les valeurs a copier
Set MonDoss = MonNameSpace.GetDefaultFolder(olFolderCalendar) 'ou le GetSharedDefaultFolder
'Pour chaque événements, on va le copier dans l'autre calendrier.
For Each EvenCalend In MonDoss.Items
'On definit les variables de l'événement, debut, fin, sujet etc.
Sujet = EvenCalend.Subject
If InStr(1, Sujet, "Congés", vbTextCompare) > 0 Then
'On definit les variables de l'événement, début, fin, sujet etc.
Sujet = EvenCalend.Subject
DateDeb = EvenCalend.Start
DateFin = EvenCalend.End
Texte = EvenCalend.Body
Lieu = EvenCalend.Location
'On fait pointer sur le second calendrier, celui où l'on va copier les infos.
Set MonDoss2 = MonNameSpace.GetDefaultFolder(olFolderCalendar)
Set MonSousDoss = MonDoss2.Folders(1)
If fc_AppointmentExist(EvenCalend.Start, EvenCalend.Subject, MonSousDoss) = False Then
'On créé un nouvel événement sur le second calendrier
Set MonObj = MonSousDoss.Items.Add(olAppointmentItem)
'On affecte les variables précédentes à début, fin, sujet etc.
MonObj.Start = DateDeb
MonObj.End = DateFin
MonObj.Subject = Sujet
MonObj.Body = Texte
MonObj.Location = Lieu
'On ferme et on sauvegarde.
MonObj.Close olSave
End If
End If
Next EvenCalend
End Sub
Private Sub test_fc_AppointmentExist()
Dim strDate
Dim MyAgendaFolder As Outlook.Folder
strDate = VBA.Format(Date - 1, "Short Date") & " 11:00 am"
Set MyAgendaFolder = Application.GetNamespace("mapi").GetDefaultFolder(olFolderCalendar)
MsgBox fc_AppointmentExist(CDate(strDate), "#123#PDF", MyAgendaFolder)
End Sub
Function fc_AppointmentExist(DateToCheck As Date, Sujet As String, MyAgendaFolder As Outlook.Folder) As Boolean
Dim searchAgenda As Items
Dim filtre
fc_AppointmentExist = False
Set searchAgenda = MyAgendaFolder.Items
If DatePart("h", DateToCheck) + DatePart("n", DateToCheck) = 0 Then
filtre = "[Start] = '" & Format(DateToCheck, "ddddd") & " 0:00 AM' " & " and [Subject] = '" & Sujet & "'"
Else
filtre = "[Start] = '" & Trim(Format(DateToCheck, "ddddd h:nn AMPM")) & "' and [Subject] = '" & Sujet & "'"
End If
Set searchAgenda = MyAgendaFolder.Items.Restrict(filtre)
If searchAgenda.Count > 0 Then fc_AppointmentExist = True
End Function