Outlook

[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
Rechercher des sujets similaires à "outlook"