Outlook
n
[Message supprimé par l'utilisateur]
Bonjour,
ci-joint 3 macro que j'ai développées ...
il faudra personnaliser la ligne
Const nomAgenda = "xxxxxxxxxxxxxxxxxxxxxxxxxx"
Attribute VB_Name = "Reponses"
Sub Reponses_Participants()
' xxx.yyy@zzz.fr ou xxx.yyy@orange.fr
' zone à paramétrer ci-dessous, enlever ou mettre une apostrophe devant les lignes à conserver ou effacer :
'###########################################################
Const nomAgenda = "xxxxxxxxxxxxxxxxxxxxxxxxxx"
'###########################################################
Const horizon = 7 ' jours
lundi = (Date - Weekday(Date, vbMonday) + 1) 'debut de la semaine en cours
Const SCRIPT_NAME = "Export de Rendez-vous OutLook vers Excel"
Dim Agenda As Object, liste As Object, Selection As Object, _
convocation As Object, participants As Outlook.Recipients, participant As Outlook.Recipient, _
xls As Object, wb As Object, ws As Object, ligne As Long
OuvrirCalendrierDe CStr(nomAgenda)
Set Agenda = Application.ActiveExplorer.CurrentFolder
If Agenda.DefaultItemType = olAppointmentItem Then
' définition de la période
periode = InputBox("Entrer les dates des convocations à analyser : ""jj/mm/aaaa jusque jj/mm/aaaa""" & vbCrLf & vbCrLf & "(par défaut depuis aujourd'hui jusque fin de la semaine prochaine)", SCRIPT_NAME, Date & " jusque " & (lundi + 7 + horizon - 1))
If periode = "" Or UBound(Split(periode, "jusque")) = 0 Then Exit Sub
temp = Split(periode, "jusque")
debut = IIf(IsDate(temp(0)), temp(0), Date) & " 00:00am"
fin = IIf(IsDate(temp(1)), temp(1), Date) & " 11:59pm"
' sélection selon dates mais avec récurrences
Set liste = Agenda.Items
liste.Sort "[Start]"
liste.IncludeRecurrences = True
Set Selection = liste.Restrict("[Start] >= '" & (debut) & "' AND [Start] <= '" & (fin) & "'")
' création du fichier excel
Set xls = CreateObject("Excel.Application")
Set wb = xls.Workbooks.Add()
Set ws = wb.Worksheets(1)
With ws
.Cells(1, 1) = "Organisateur"
.Cells(1, 2) = "Objet"
.Cells(1, 3) = "Lieu"
.Cells(1, 4) = "Date & heure"
.Cells(1, 5) = "Participants"
.Cells(1, 6) = "Type"
.Cells(1, 7) = "Réponse"
End With
ligne = 2
' renseignement du fichier excel
For Each convocation In Selection
If convocation.Class = olAppointment Then ' And convocation.Organizer = nomAgenda
Set participants = GetRecipients(convocation)
For i = 1 To participants.Count
If convocation.Organizer = nomAgenda Then
Set participant = participants.Item(i)
If convocation.Organizer <> GetRecipientName(participant) Then
ws.Cells(ligne, 1) = convocation.Organizer
ws.Cells(ligne, 2) = convocation.Subject
ws.Cells(ligne, 3) = convocation.Location
ws.Cells(ligne, 4) = Format(convocation.Start, "mm/dd/yyyy hh:nn") ' c'est assez curieux, mais cela permet d'avoir des jour/mois/année !!
ws.Cells(ligne, 5) = GetRecipientName(participant)
ws.Cells(ligne, 6) = GetType(participant.Type)
ws.Cells(ligne, 7) = GetResponseStatus(participant.MeetingResponseStatus)
ligne = ligne + 1
End If
Set participant = Nothing
End If
Next i
End If
Next
ws.Columns("A:K").AutoFit
xls.Visible = True
' fin de renseignement du fichier excel et affichage (pas de sauvegarde)
Set ws = Nothing
Set wb = Nothing
Set xls = Nothing
Set liste = Nothing
Else
MsgBox "Operation annulée. Le dossier courant n'est pas un calendrier. Positionnez-vous sur un calendrier valide !", vbCritical + vbOKOnly, SCRIPT_NAME
End If
Set Agenda = Nothing
End Sub
Attribute VB_Name = "Relances"
Sub Relances_Participants()
' xxx.yyy@zzz.fr ou xxx.yyy@orange.fr
' zone à paramétrer ci-dessous, enlever ou mettre une apostrophe devant les lignes à conserver ou effacer :
'###########################################################
Const nomAgenda = "xxxxxxxxxxxxxxxxxxxxxxxxxx"
Const message = "Merci de nous confirmer votre participation à la réunion en objet !"
'###########################################################
Const horizon = 7 ' jours
lundi = (Date - Weekday(Date, vbMonday) + 1) 'debut de la semaine en cours
Const nomMacro = "Relance des participants obligatoires n'ayant pas répondu !"
Dim Agenda As Object, liste As Object, Selection As Object, convocation As Object, participants As Outlook.Recipients, participant As Outlook.Recipient
Dim messagerie As Object, email As Object, nombre As Integer
OuvrirCalendrierDe CStr(nomAgenda)
Set Agenda = Application.ActiveExplorer.CurrentFolder
If Agenda.DefaultItemType = olAppointmentItem Then
' définition de la période
periode = InputBox("Entrer les dates des convocations à analyser : ""jj/mm/aaaa jusque jj/mm/aaaa""" & vbCrLf & vbCrLf & "(par défaut depuis aujourd'hui jusque fin de la semaine prochaine)", SCRIPT_NAME, Date & " jusque " & (lundi + 7 + horizon - 1))
If periode = "" Or UBound(Split(periode, "jusque")) = 0 Then Exit Sub
temp = Split(periode, "jusque")
debut = IIf(IsDate(temp(0)), temp(0), Date) & " 00:00am"
fin = IIf(IsDate(temp(1)), temp(1), Date) & " 11:59pm"
' sélection selon dates, avec récurrences
Set liste = Agenda.Items
liste.Sort "[Start]"
liste.IncludeRecurrences = True
Set Selection = liste.Restrict("[Start] >= '" & (debut) & "' AND [Start] <= '" & (fin) & "'")
Set messagerie = CreateObject("Outlook.Application")
' traitement de chaque convocation
nombre = 0
For Each convocation In Selection
If convocation.Class = olAppointment Then
Set participants = GetRecipients(convocation)
For i = 1 To participants.Count
If convocation.Organizer = nomAgenda Then
Set participant = participants.Item(i)
' obligatoire néant provisoire sans réponse
If participant.Type = 1 And (participant.MeetingResponseStatus = 0 Or participant.MeetingResponseStatus = 2 Or participant.MeetingResponseStatus = 5) And GetRecipientName(participant) <> convocation.Organizer Then
Set email = messagerie.CreateItem(0)
With email
.To = GetRecipientName(participant)
.Subject = convocation.Subject & " du " & Format(convocation.Start, "dd/mm/yyyy hh:nn")
.HTMLBody = message
.Display '.send
End With
Set email = Nothing
nombre = nombre + 1
End If
Set participant = Nothing
End If
Next i
End If
Next
Set messagerie = Nothing
MsgBox "Opération terminée : " & nombre & " relance(s) !"
Else
MsgBox "Operation annulée. Le dossier courant n'est pas un calendrier. Positionnez-vous sur un calendrier valide !", vbCritical + vbOKOnly, nomMacro
End If
Set convocation = Nothing
Set liste = Nothing
Set Agenda = Nothing
End Sub
Attribute VB_Name = "fonctions"
Function GetRecipients(itm As Object) As Outlook.Recipients
Dim obj As Object
Dim recips As Outlook.Recipients
Dim types() As String
types = Split("MailItem,AppointmentItem,JournalItem,MeetingItem,TaskItem", ",")
If UBound(Filter(types, TypeName(itm))) > -1 Then ' it's a matching item
Set obj = itm
Set recips = obj.Recipients
Set GetRecipients = recips
End If
End Function
Function GetRecipientName(meetingRecip As Outlook.Recipient) As String
GetRecipientName = meetingRecip.Name
End Function
Function GetType(attendeeType As OlMeetingRecipientType) As String
Select Case attendeeType
Case 0 ' olOrganizer
GetType = "Organisateur"
Case 1 ' olRequired
GetType = "Participant attendu"
Case 2 ' olOptional
GetType = "Participant facultatif"
Case 3 ' olResource
GetType = "Ressource"
End Select
End Function
Function GetResponseStatus(status As OlResponseStatus) As String
Select Case status
Case 0
GetResponseStatus = "Néant"
Case 1
GetResponseStatus = "Organisateur"
Case 2
GetResponseStatus = "Provisoire"
Case 3
GetResponseStatus = "Accepté"
Case 4
GetResponseStatus = "Décliné"
Case 5
GetResponseStatus = "Sans réponse" ' il semble qu'en cas de non-réponse ce soit la valuer 0, donc Néant
End Select
End Function
Function GetEmail(recip As Outlook.Recipient)
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set pa = recip.PropertyAccessor
GetEmail = pa.GetProperty(PR_SMTP_ADDRESS)
End Function
Sub OuvrirCalendrierDe(owner As String)
Dim myolApp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.MAPIFolder
Set myolApp = CreateObject("Outlook.Application")
Set myNameSpace = myolApp.GetNamespace("MAPI")
If owner = "" Then Exit Sub
Set myRecipient = myNameSpace.CreateRecipient(owner)
myRecipient.Resolve
If myRecipient.Resolved Then
Call AfficherCalendrier(myNameSpace, myRecipient)
End If
End Sub
Sub AfficherCalendrier(myNameSpace, myRecipient)
Dim CalendarFolder As Outlook.MAPIFolder
Set CalendarFolder = myNameSpace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
CalendarFolder.Display
End Sub