Restore des anniversaires dans outlook

Commenter

Contenu du snippet

Bon, avec les synchros avec les smartphones etc... il arrive qu'on ait des doublons ou des anniversaires qui durent 2 jours. Il arrive qu'on les supprime et pas moyen de les regénérer automatiquement à partir de la liste de contacts... C'est la raison de ce script vbs. Il visite les contacts et créé les anniversaires et fêtes/anniversaires de mariage quand ils sont présents.
Je sais qu'il marche avec Outlook 2003, je n'ai pas testé les autres versions...

Source / Exemple : 


'*********************************************
'*********************************************
'**                                         **
'**             restoreBdays.vbs            **
'**   Restore Birthdays and Anniversaries   **
'**               Version 1.0               **
'**             ---------------             **
'**             Benoît DESTRUBÉ             **
'**              bennd@free.fr              **
'**      http://www.instantmagique.net      **
'**                                         **
'*********************************************
'*********************************************

'This script goes through your contacts and adds a yearly appointment for every birthday or Anniversary

Dim objOLApp 'As Outlook.Application
Dim objOLSession 'As Outlook.NameSpace
Dim objCDOSession 'As MAPI.Session
Dim objCDOFolder 'As MAPI.Folder
  ' Reference the folder by using CDO
  
Const CdoDefaultFolderCalendar		= 9	 	'Calendar  
Const CdoDefaultFolderContacts		= 10  	'Contacts  

RestoreBdays

Sub RestoreBdays()
  Dim MyCurrentUser
  'Get the Outlook objects
  Set objOLApp = CreateObject("Outlook.Application")
  Set objOLSession = objOLApp.Session
  
  'Get the CDO objects, using the existing Outlook session for CDO logon
  Set objCDOSession = CreateObject("MAPI.Session")
  objCDOSession.SetLocaleIDs LocaleId, CodePage
  objCDOSession.Logon , , False, False
  
  Set myCalendarFolder = objOLSession.GetDefaultFolder(CdoDefaultFolderCalendar)
  Set myContactFolder = objOLSession.GetDefaultFolder(CdoDefaultFolderContacts)
  
  'Get the contact items and check if there are any...
  Set myItems = myContactFolder.items
  myCount = myItems.Count
  If myCount = 0 Then
    MsgBox "Nothing to do!"
    Exit Sub
  End If
  
  'Filter on the message class to obtain only contact items in the folder
  Set myContactItems = myItems.Restrict("[MessageClass]='IPM.Contact'")
  
  For Each contactItem In myContactItems
  'Go through all the items in the Contacts folder
  
  
    'An empty birthday has "01/01/4501" as it's date
    If contactItem.Birthday <> "01/01/4501" Then
      'wscript.echo contactItem.FirstName & " " & contactItem.LastName & " anniv " & contactItem.Birthday
      'Create a  new appointment------------------------------------------------------------
      Set myNewAppointment = myCalendarFolder.Items.Add
      If Not myNewAppointment Is Nothing Then
        With myNewAppointment
          .Subject = "Anniversaire de " & contactItem.FirstName & " " & contactItem.LastName
          .Start = Cdate(contactItem.Birthday)
          .AllDayEvent = True
        End With
        Set myRecurrPatt = myNewAppointment.GetRecurrencePattern
        myRecurrPatt.RecurrenceType = 5 'Make it a yearly event
        myNewAppointment.Save
      End If
      '-------------------------------------------------------------------------------------
    End If
    
    'An empty Anniversary has "01/01/4501" as it's date
    IF contactItem.Anniversary <> "01/01/4501" Then
      'wscript.echo contactItem.FirstName & " " & contactItem.LastName & " fete " & contactItem.Anniversary
      'Create a  new appointment------------------------------------------------------------
      Set myNewAppointment = myCalendarFolder.Items.Add
      If Not myNewAppointment Is Nothing Then
        With myNewAppointment
          .Subject = "Anniversaire de mariage ou fête de " & contactItem.FirstName & " " & contactItem.LastName
          .Start = Cdate(contactItem.Anniversary)
          .AllDayEvent = True
        End With
        Set myRecurrPatt = myNewAppointment.GetRecurrencePattern
        myRecurrPatt.RecurrenceType = 5 'Make it a yearly event
        myNewAppointment.Save
      End If
      '-------------------------------------------------------------------------------------
    End If
  Next

  'Clean up before leaving...
  objCDOSession.Logoff
  Set objCDOSession = Nothing
  Set objOLSession = Nothing
  Set objOLApp = Nothing
End Sub

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.