Посылка письма со списком ближайших дней рождения

В числе прочего, в этих карточках хранятся дни рождения.

Чтобы не забывать о них и заранее к ним готовиться, я написал скрипт, который просматривает папку Contacts и ее подпапки, составляет список ближайших дней рождений, и посылает мне письмо с этой информацией. Этот скрипт вызывается каждое утро планировщиком задач Windows.

Комментарии к коду:

• Для доступа к моему почтовому ящику используется библиотека CDO версии 1.21.
• Прежде всего, скрипт открывает MAPI-сессию. В качестве профайла используем профайл по умолчанию. Чтобы узнать его, используется функция GetDefaultMapiProfile, описанная мной здесь.
• Просмотр папок происходит рекурсивно (в процедуре ProcessFolder), начиная со стандартной папки Contacts.
• День рождения находится в поле PR_BIRTHDAY (тэг определен в файле mapitags.h).
• Если этого поля нет, то при попытке его извлечь CDO генерирует ошибку CdoE_NOT_FOUND, поэтому необходимо отлавливать ошибки с помощью On Error Resume Next.
• Чтобы вычислить разницу в днях между днем рождения и текущей датой, используется функция DateDiff с параметром "y".
• Поскольку день рождения и текущая дата находятся (как правило) в разных годах, то приходится приводить дни рождения к текущему году с помощью функции DateSerial.
• Обратите внимание, как указывается получатель для посылки письма самому себе.

Листинг: birthdays.vbs

Option Explicit

' открываем сессию MAPI с помощью профайла по умолчанию
Dim Session
Set Session = CreateObject("MAPI.Session")
Session.Logon GetDefaultMapiProfile

' в этой строке будет собираться информация о днях рождения
Dim Body

' будет использоваться для приведения дня рождения к текущему году
Dim CurrentYear
CurrentYear = Year(Now)

' получаем корневую папку Contacts
Dim Root
Set Root = Session.GetDefaultFolder(5)  ' 5 = CdoDefaultFolderContacts

' начинаем рекурсивную обработку папок
ProcessFolder Root

' отсылаем самому себе письмо со списком ближайших дней рождения
Dim Message
Set Message = Session.Outbox.Messages.Add("Ближайшие дни рождения", Body)
' в качестве получателя указываем идентификатор текущего пользователя
Message.Recipients.Add ,, 1, Session.CurrentUser.ID
Message.Update
Message.Send False, False

' закрываем сессию MAPI

Session.Logoff
Set Session = Nothing

'---------------------------------------------------------------------

' эта функция используется для рекурсивной обработки папок

Sub ProcessFolder(Folder)

    ' просматриваем все карточки

    Dim Message
    For Each Message In Folder.Messages
        ' ищем день рождения
        Dim Value
        On Error Resume Next
        Err.Clear
        Value = Message.Fields(&H3A420040) ' 0x3A420040 = PR_BIRTHDAY
        If Err.Number <> 0 Then Value = ""
        On Error GoTo 0

        If Len(Value) > 0 Then
            Dim Birthday
            Birthday = CDate(Value)
            ' приводим день рождения к текущему году
            Birthday = _
            	DateSerial(CurrentYear, Month(Birthday), Day(Birthday))
            ' вычисляем разницу в днях между днем рождения и текущей датой
            Dim Diff
            Diff = DateDiff("y", Now, Birthday)
            If (Diff >= 0) And (Diff <= 7) Then
                ' если она меньше 7 - добавляем информацию о нем в письмо
                Body = Body & Birthday & vbTab & Message.Subject & vbNewLine
            End If
        End If
    Next
    
    ' рекурсивно просматриваем все подпапки

    Dim SubFolder
    For Each SubFolder In Folder.Folders
        ProcessFolder SubFolder
    Next
End Sub

'---------------------------------------------------------------------

' эта функция возвращает имя MAPI-профайла по умолчанию

Function GetDefaultMapiProfile()
    Dim Shell
    Set Shell = WScript.CreateObject("WScript.Shell")

    Dim RegKey9x, RegKeyNT
    RegKey9x = _
        "HKCU\Software\Microsoft\Windows Messaging Subsystem\" & _
        "Profiles\DefaultProfile"
    RegKeyNT = _
        "HKCU\Software\Microsoft\Windows NT\CurrentVersion\" & _
        "Windows Messaging Subsystem\Profiles\DefaultProfile"
    
    On Error Resume Next
    Err.Clear
    GetDefaultMapiProfile = Shell.RegRead(RegKey9x)
    If Err.Number <> 0 Then 
        Err.Clear
        GetDefaultMapiProfile = Shell.RegRead(RegKeyNT)
        If Err.Number <> 0 Then GetDefaultMapiProfile = ""
    End If
    
    Set Shell = Nothing
End Function

'---------------------------------------------------------------------

Смотри также