Excel et Calendrier Outlook

[arno_]

Bonjour,

J'ai une macro qui me permet d'ajouter des rendez-vous dans mon calendrier outlook qui marche bien (merci à vous pour la macro trouve dans ce forum).

J'aimerai aller plus loin, j'aimerai que cette macro vérifie si le rendez-vous existe deja ... si il existe je voudrais qu'elle n'ajoute pas le rdv afin de ne pas me retrouver avec des doublons.

J'ai fait pas mal d'essai mais impossible de trouver la solution (je suis nul en vba).

Dans l'idée je me disai qu'avant d'inserer le rdv il faut verifier si a la meme date de debut j'avais un rdv avec le meme sujet ... si c'est le cas alors ou insert sinon on va a la suite.

Voici ma macro actuel :

Sub add_Calendrier()
On Error GoTo HandleError
Dim OutObj As Object
Dim OutAppt As Object


r = 7
While Sheets("Suivi Général").Cells(r, 2).Value <> ""
If Sheets("Suivi Général").Cells(r, 17).Value >= Now() Then
Set OutObj = CreateObject("Outlook.Application")
Set OutAppt = OutObj.CreateItem(olAppointmentItem)
With OutAppt
.Start = Sheets("Suivi Général").Cells(r, 17).Value '"08/11/2007 10:00" Date et Heure du début du RDV
.Duration = 120 'Durée du RDV en minute
'Subject de la forme "Ref - RDV - variable - variable
.Subject = Sheets("Suivi Général").Cells(r, 15).Value & " - RDV - " & Sheets("Suivi Général").Cells(r, 2).Value & " - " & Sheets("Suivi Général").Cells(r, 3).Value
.Body = "N° Commande : " & Sheets("Suivi Général").Cells(r, 14).Value & " / " & "id : " & Sheets("Suivi Général").Cells(r, 5).Value
.ReminderSet = False
.Save
End With
Set OutObj = Nothing
End If
r = r + 1
Wend

HandleError:
Debug.Print Err.Description
End Sub


Auriez vous une idée, une piste un lien à me donner pour m'orienter dans la jungle vba 😉

 

[MichelXld]

Re : Excel et Calendrier Outlook

bonsoir


Cet exemple vérifie si un Rdv commence à la même heure mais pas s'il y en a deja un en cours:

Dim OutlApp As New Outlook.Application
Dim OutlMapi As Outlook.Namespace
Dim OutlFolder As Outlook.MAPIFolder
Dim OutlAppointment As Outlook.AppointmentItem
Dim OutlItems As Outlook.Items
Dim DateDebut As String

DateDebut = "31/03/2008 19:00"

Set OutlMapi = OutlApp.GetNamespace("MAPI")
Set OutlFolder = OutlMapi.GetDefaultFolder(olFolderCalendar)
Set OutlItems = OutlFolder.Items
 
 
On Error Resume Next
Set OutlAppointment = OutlItems.Find("[Start] = '" & DateDebut & "'")
On Error GoTo 0

If OutlAppointment Is Nothing Then
    MsgBox "Ok"
Else
    MsgBox "Un Rdv déja prévu à cette date:" & vbCrLf & _
        OutlAppointment.Subject
End If

Bonne soirée
MichelXld