When I created by evenements nothing is displayed on the calendar.
my code in vb6 :
Dim StrSujet As String Dim StartTime As Date, EndTime As Date Dim lngTmpIdSoin As Long Dim RR As ADODB.Recordset Dim RE As ADODB.Recordset Dim RC As New ADODB.Recordset Dim calEvent As CalendarEvent Set RE = New ADODB.Recordset Set RC = New ADODB.Recordset Set RR = New ADODB.Recordset strSQL = "SELECT * FROM AGENDA WHERE IdSite = " & lngNSite & " AND Supprimer = 0" RE.Open strSQL, ObjConnect.ADOConnectionObject, adOpenStatic Do While Not RE.EOF StartTime = RE.Fields("DateHeureRVD").Value EndTime = RE.Fields("DateHeureRVF").Value StrSujet = vbNullString Set calEvent = g_DataResourcesMan.DataProvider(0).CreateEventEx(RE.Fields("IdAgenda").Value) 'Set calEvent = Me.CalendarControl.DataProvider.CreateEventEx(RE.Fields("IdAgenda").Value) calEvent.StartTime = StartTime calEvent.EndTime = EndTime strSQL = "SELECT * FROM CLIENT WHERE IdClient = " & RE.Fields("IdClient").Value & " AND IdSite = " & lngNSite RC.Open strSQL, ObjConnect.ADOConnectionObject, adOpenStatic If Not RC.EOF Then strSQL = "SELECT * FROM CIVILITE WHERE IdCivilite = " & RC.Fields("IdCivilite").Value RR.Open strSQL, ObjConnect.ADOConnectionObject, adOpenStatic If Not RR.EOF Then StrSujet = StrSujet & RR.Fields("Libelle").Value & Space$(1) & RC.Fields("Nom").Value & " " & RC.Fields("Prenom").Value Else StrSujet = StrSujet & RC.Fields("Nom").Value & " " & RC.Fields("Prenom").Value End If RR.Close Else StrSujet = "Aucun Client" End If RC.Close StrSujet = StrSujet & Space$(1) & FormatDateTime(StartTime, vbShortTime) & " - " & FormatDateTime(EndTime, vbShortTime) calEvent.Subject = StrSujet calEvent.ScheduleID = RE.Fields("IdLieu").Value calEvent.CustomProperties("IdAgenda") = RE.Fields("IdAgenda").Value calEvent.CustomProperties("IdLieu") = RE.Fields("IdLieu").Value calEvent.BusyStatus = xtpCalendarBusyStatusBusy 'Afficher les soins Agendas If RetrieveEnv("AFFICHER_SOIN_AGENDA", , True) <> "0" And RetrieveEnv("AFFICHER_SOIN_AGENDA", , True) <> vbNullString Then If RE.Fields("IdSoin").Value > 0 Then If RE.Fields("IdSousSoin").Value > 0 Then lngTmpIdSoin = RE.Fields("IdSousSoin").Value Else lngTmpIdSoin = RE.Fields("IdSoin").Value End If strSQL = "SELECT * FROM ARTICLE WHERE IdArticle = " & lngTmpIdSoin RR.Open strSQL, ObjConnect.ADOConnectionObject, adOpenStatic If Not RR.EOF Then calEvent.Location = "Soins : " & RR.Fields("Libelle").Value & IIf(RR.Fields("Duree_Abonnement").Value > 0, " (" & RR.Fields("Duree_Abonnement").Value & " min.)", vbNullString) Else calEvent.Location = "Soins : " & "Aucun" End If RR.Close Else calEvent.Location = "Soins : " & "Aucun" End If End If 'Afficher les Estheticienne Agendas strSQL = "SELECT * FROM VACATAIRE WHERE IdVacataire = " & RE.Fields("IdOperateur").Value RR.Open strSQL, ObjConnect.ADOConnectionObject, adOpenStatic If Not RR.EOF Then calEvent.Body = "Esthéticien(ne) : " & RR.Fields("Nom").Value & Space$(1) & RR.Fields("Prenom").Value Else calEvent.Body = "Esthéticien(ne) : Aucun" End If RR.Close g_DataResourcesMan.DataProvider(0).AddEvent calEvent 'Me.CalendarControl.DataProvider.AddEvent calEvent CalendarControl.Populate CalendarControl.RedrawControl RE.MoveNext Loop RE.Close
Thanks
|