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