piloter macro outlook depuis excel

[djdmd14]

bonjour
j ai une macro excel qui ecrit des rendez vous dans mon calendrier outlook

Sub ajoute_rdv_agenda()
Dim MonOutlook As New Outlook.Application
Dim rdv As Outlook.AppointmentItem
Dim nbjour As Outlook.RecurrencePattern

Set rdv = MonOutlook.CreateItem(olAppointmentItem)

With rdv
    .MeetingStatus = olMeeting
    .Subject = "Prestation " & Range("nom_client")
    .Body = Range("obj_mission")
    .BusyStatus = olBusy
    .Categories = Range("nom_client")
    .Start = Range("date_mission") + TimeSerial(8, 0, 0)
    .Duration = 540
    .ReminderSet = False
    
Set nbjour = rdv.GetRecurrencePattern
With nbjour
    .RecurrenceType = olRecursDaily
    .PatternStartDate = Range("date_mission")
    .PatternEndDate = Range("date_fin")
    
rdv.Save
End With
End With

'MonOutlook.Quit
Set MonOutlook = Nothing
Set rdv = Nothing

et j ai dans outlook une macro qui quand je crée un rdv,en fait la copie vers un autre calendrier partagé

Public Sub CopyRDV()

On Error GoTo AddAppt_Err

Dim OutObj As Outlook.Application
Dim MyRDV As Outlook.AppointmentItem
Dim OutAppt As Outlook.AppointmentItem
Dim MyCalendarItem As Outlook.Items
Dim MyCalendarFolder As Outlook.MAPIFolder

Set OutObj = CreateObject("Outlook.Application")
Set MyRDV = ActiveInspector.CurrentItem

Set MyCalendarFolder = OutObj.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Folders.Item("calendrier2")

MyRDV.Close olPromptForSave

If MyRDV.Saved Then
Set OutAppt = MyRDV.Copy
With OutAppt
If MyRDV.BusyStatus = olBusy Then _
.Subject = "Occupé"
.ReminderSet = False
.Save
End With
OutAppt.Move MyCalendarFolder
End If

Set OutObj = Nothing ' Retire de la mémoire les objets créer

Exit Sub

AddAppt_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub

j aimerais savoir comment faire pour piloter cette 2 eme macro directement depuis excel afin que mes rdv créés à partir de la premiere macro oit automatiquement recopié vers l autre calendrier sans que j ai à le faire à la main
merci d avance

 

[djdmd14]

Resolu : piloter macro outlook depuis excel

ça y est j' ai trouvé tout seul

Sub ajoute_rdv_agenda()
Dim MonOutlook As New Outlook.Application
Dim rdv As Outlook.AppointmentItem
Dim rdvcop As Outlook.AppointmentItem
Dim nbjour As Outlook.RecurrencePattern
Dim calend2 As Outlook.MAPIFolder

Set calend2 = MonOutlook.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Folders.Item("calendrier2")

Set rdv = MonOutlook.CreateItem(olAppointmentItem)

With rdv
    .MeetingStatus = olNonMeeting
    .Subject = "Prestation " & Range("nom_client")
    .Body = Range("obj_mission")
    .BusyStatus = olBusy
    .Categories = Range("nom_client")
    .Start = Range("date_mission") + TimeSerial(8, 0, 0)
    .Duration = 540
    .ReminderSet = False
    
Set nbjour = rdv.GetRecurrencePattern
With nbjour
    .RecurrenceType = olRecursDaily
    .PatternStartDate = Range("date_mission")
    .PatternEndDate = Range("date_fin")
    
rdv.Save
Set rdvcop = rdv.Copy
With rdvcop
    .Subject = "Occupé"
    .ReminderSet = False
    .Save
End With
End With
rdvcop.Move calend2
End With

'MonOutlook.Quit
Set MonOutlook = Nothing
Set rdv = Nothing

   


End Sub