Данный пример показывает как можно создать календарь,
используя 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
| |
