Bonsoir
je reviens sur mon probleme de choix de calendrier, j'ai fait une modification pour modifier le "Calendrier_PR", apparement il e trouve mais ca termine en cata dans la ligne "SET MYITEM" en couleur.
Voici le code, il lit un tableau excel et cree des rendez-vous, si tu peux trouver ce qui manque, je pense que mes maux de tete seront soulages-
D'avance merci
Jean-Louis
Sub SYNCHRO_PR()
On Error GoTo erreurapp
Call SupprimerRDVPR
'nécéssite d'activer la référence Microsoft Outlook 10.0 Object Library
Dim myOlApp As New Outlook.Application
Dim myItem As Outlook.AppointmentItem
Dim myCalendar As Outlook.Items
Dim Cell As Range
Dim deleg1
Dim D As Long
Dim premlivide As Long
Set myOlApp = CreateObject("outlook.application")
Set myCalendar = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Folders.Item("Calendrier_PR").Items
premlivide = 0
Sheets("SYNC_PR").Select
premlivide = Columns(1).Find("", [A65536], , , xlByRows, xlNext).Row
For D = 2 To premlivide
If Cells(D, 1) = "" Then GoTo exisub
If Cells(D, 2) = "KO" Then GoTo suite
If Cells(D, 2) = "DB" Then GoTo suite
Set myItem = myCalendar.CreateItem(olAppointmentItem) (ERREUR 438 Propriete ou methode non geree par cet objet?)
With myItem
.MeetingStatus = olNonMeeting
.AllDayEvent = True '"EX:AllDayEvent"
deleg1 = Cells(D, 9) & Chr(13)
For xx = 1 To 20
If Cells(D + xx, 2) = "DB" And Cells(D + xx, 3) = Cells(D, 3) Then GoTo maj
GoTo yy
maj:
If Cells(D + xx, 9) = Cells(D + xx - 1, 9) Then GoTo yy1
deleg1 = deleg1 & " " & Cells(D + xx, 9) & Chr(13)
yy1:
Next xx
yy:
.Body = "N° " & Cells(D, 1) & " " & "SAP PROJET : " & Cells(D, 3) & Chr(13) & Cells(D, 6) & Chr(13) & "Délégués : " + deleg1 & "Responsable : " + Cells(D, 33) '"EX:Body"
.Categories = "PR"
.Location = Cells(D, 7) '"EX:Location"
.ReminderSet = False
.ReminderSoundFile = False '"EX:ReminderSoundFile"
.Start = Cells(D, 4) '"EX:Start"
.Subject = Cells(D, 5) '"EX:Subject" prendre les 30 premieres positions
.Save
End With
Set myItem = Nothing
suite:
Next D
exisub:
Exit Sub
erreurapp:
MsgBox "Erreur Synchro Outlook (création) " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub