Программирование на Visual Basic

Данный пример показывает как можно создать календарь, используя ActiveX Calendar от Microsoft. Поставьте ссылку на C:\Program Files\Microsoft Office\OFFICE11\MSCALL.OCX. Применяется класс для создания календаря.

Option Compare Database
Option Explicit

Public WithEvents CurrentCal As MicrosoftCal

'   Настройка календаря
Private Sub Form_Load()
    Set CurrentCal = New MicrosoftCal
    Set CurrentCal.Cal = Me.myCal.Object
    With Me.CurrentCal.Cal ' Настройка календаря
        '.Value = Date ' Установка текущей даты
        .TitleFontColor = 255 ' Цвет заголовка
        .Year = Year(Date) ' Устанавливаем год
        .Month = Month(Date) ' Устанавливаем месяц
        .Day = Day(Date) ' Уставливаем день
        .NextDay ' Следующий день
        '.ShowTitle = False ' Гасим заголовок
        ' Введите точку и установите параметр
    End With
End Sub

'   Добавим событие-сообщение для нового класса
Public Sub CurrentCal_Progress(myMsg As String)
    If Me.butEvents Then
        Me.myEvents = myMsg  vbNewLine  Me.myEvents
        DoEvents
    End If
End Sub

'   Установлена дата
Public Sub myCal_AfterUpdate()
    'CurrentCal_Progress "Date: "  Me.myCal
End Sub

'   События для формы
Private Sub myCal_GotFocus()
    CurrentCal_Progress "GotFocus"
End Sub
Private Sub myCal_LostFocus()
    CurrentCal_Progress "LostFocus"
End Sub
Private Sub butEvents_AfterUpdate()
    Me.myEvents = ""
End Sub

'==============================================================

' Объявляем класс Calendar
Public WithEvents Cal As Calendar

' Объявляем событие для сообщений
Public Event progress(strMsg As String)

'==============================================================
'  События при создании/уничтожении класса
Private Sub Class_Initialize()
   ' Инициализация
End Sub
Private Sub Class_Terminate()
   ' Сохраняем данные
End Sub

'==============================================================
'  События до/после редактирования метки узла
Private Sub Cal_AfterUpdate()
   funPrintEvent "AfterUpdate: "  Me.Cal.Value
End Sub
Private Sub Cal_BeforeUpdate(Cancel As Integer)
   funPrintEvent "BeforeUpdate: "  Me.Cal.Value
End Sub
Private Sub Cal_NewMonth()
   funPrintEvent "NewMonth: "  Me.Cal.Value
End Sub
Private Sub Cal_NewYear()
   funPrintEvent "NewYear: "  Me.Cal.Value
End Sub

'==============================================================
'  События мышки
Private Sub Cal_Click()
   funPrintEvent "Click"
End Sub
Private Sub Cal_DblClick()
   funPrintEvent "DblClick"
End Sub

'==============================================================
'  События клавиатуры
Private Sub Cal_KeyDown(KeyCode As Integer, ByVal Shift As Integer)
   funPrintEvent "KeyDown (KeyCode: "  KeyCode  ", Shift = "  Shift  ")"
End Sub
Private Sub Cal_KeyPress(KeyAscii As Integer)
   funPrintEvent "KeyPress: "  KeyAscii
End Sub
Private Sub Cal_KeyUp(KeyCode As Integer, ByVal Shift As Integer)
    funPrintEvent "KeyUp (KeyCode: "  KeyCode  ", Shift = "  Shift  ")"
End Sub

'==============================================================
'   Функция сообщающая о получении событий
Private Function funPrintEvent(myMsg As String)
    RaiseEvent progress(myMsg) ' Генерируем событие для узла
End Function