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

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