📄 ctlkalender.ctl
字号:
VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.UserControl ctlKalender
BackColor = &H8000000A&
ClientHeight = 3600
ClientLeft = 0
ClientTop = 0
ClientWidth = 4800
ScaleHeight = 3600
ScaleWidth = 4800
Begin MSFlexGridLib.MSFlexGrid msfMonth
Height = 2940
Left = 0
TabIndex = 1
Top = 375
Width = 4215
_ExtentX = 7430
_ExtentY = 5186
_Version = 393216
RowHeightMin = 300
ForeColor = -2147483642
ForeColorFixed = -2147483640
BackColorSel = 8885785
BackColorBkg = 16777215
GridColorFixed = 8421504
Redraw = -1 'True
FocusRect = 0
GridLinesFixed = 1
ScrollBars = 0
BorderStyle = 0
Appearance = 0
End
Begin VB.Image imgDate
Height = 192
Left = 4500
Picture = "ctlKalender.ctx":0000
Top = 3072
Width = 192
End
Begin VB.Image imgToday
Height = 192
Left = 4500
Picture = "ctlKalender.ctx":0286
Top = 3300
Visible = 0 'False
Width = 192
End
Begin VB.Image imgMonthPrev
Height = 192
Left = 0
Picture = "ctlKalender.ctx":06A3
Top = 0
Width = 192
End
Begin VB.Image imgMonthNext
Height = 192
Left = 228
Picture = "ctlKalender.ctx":0773
Top = 0
Width = 192
End
Begin VB.Image imgYearPrev
Height = 192
Left = 4272
Picture = "ctlKalender.ctx":0844
Top = 0
Width = 192
End
Begin VB.Image imgYearNext
Height = 192
Left = 4500
Picture = "ctlKalender.ctx":0914
Top = 0
Width = 192
End
Begin VB.Label lblMonthYear
Alignment = 2 'Center
BackColor = &H00808080&
Caption = "Jahr"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H8000000E&
Height = 315
Left = 0
TabIndex = 0
Top = 0
Width = 4740
End
End
Attribute VB_Name = "ctlKalender"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private ColCount As Integer
Private ColWidth As Long
Private FirstDayOfMonth As Integer
Private DayArray(30) As Byte
Private m_DateValue As Date
Private m_DaysOfMonth As Integer
Public Event DateChanged(NewDate As Date)
Private Sub imgMonthNext_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
DateValue = DateAdd("m", 1, DateValue)
End Sub
Private Sub imgMonthPrev_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
DateValue = DateAdd("m", -1, DateValue)
End Sub
Private Sub imgYearNext_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
DateValue = DateAdd("yyyy", 1, DateValue)
End Sub
Private Sub imgYearPrev_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
DateValue = DateAdd("yyyy", -1, DateValue)
End Sub
Private Sub msfMonth_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
On Error Resume Next
Dim dumDayNumber As Integer
Dim oldRow As Integer
Dim oldCol As Integer
With msfMonth
If .Row > 0 Then
If .TextMatrix(.Row, .Col) <> "" Then
oldRow = .Row
oldCol = .Col
If IsNumeric(.TextMatrix(.Row, .Col)) Then
dumDayNumber = CInt(.Text)
DateValue = DateSerial(Year(m_DateValue), Month(m_DateValue), dumDayNumber)
End If
.Row = oldRow
.Col = oldCol
End If
End If
End With
End Sub
Private Sub msfMonth_SelChange()
On Error Resume Next
With msfMonth
.ColSel = .Col
.RowSel = .Row
End With
End Sub
Private Sub UserControl_Initialize()
msfMonth.Rows = 7
msfMonth.FixedRows = 1
msfMonth.Cols = 7
msfMonth.FixedCols = 0
End Sub
Private Sub UserControl_InitProperties()
m_DateValue = DateTime.Date
FillCalendar (m_DateValue)
UpdateTitleLabel
End Sub
Private Sub UserControl_Paint()
Line (0, 0)-(ScaleWidth - Screen.TwipsPerPixelX, ScaleHeight - Screen.TwipsPerPixelY), RGB(132, 130, 132), B
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_DateValue = PropBag.ReadProperty("DateValue", DateTime.Date)
FillCalendar (m_DateValue)
UpdateTitleLabel
End Sub
Private Sub UserControl_Resize()
On Error Resume Next
Dim lngDayLblSize As Long
Dim FieldHeight As Long
ColWidth = ScaleWidth \ 7
Width = ColWidth * 7
With lblMonthYear
.Top = 0
.Left = 0
.Width = ScaleWidth
End With
With imgYearPrev
.Left = ScaleWidth - (2 * .Width) - 60
.Top = (lblMonthYear.Height - .Height) / 2
End With
With imgYearNext
.Left = lblMonthYear.Width - .Width - 30
.Top = (lblMonthYear.Height - .Height) / 2
End With
With imgMonthPrev
.Left = 30
.Top = (lblMonthYear.Height - .Height) / 2
End With
With imgMonthNext
.Left = .Width + 60
.Top = (lblMonthYear.Height - .Height) / 2
End With
With msfMonth
.Top = lblMonthYear.Height
.Left = 15
.Width = ScaleWidth - 30
.Height = ScaleHeight - lblMonthYear.Height - 15
End With
Dim CurCol As Byte
Dim curRow As Byte
For CurCol = 0 To 6
msfMonth.ColWidth(CurCol) = ColWidth
Next
For curRow = 1 To 6
msfMonth.RowHeight(curRow) = (ScaleHeight - msfMonth.RowHeight(0) - lblMonthYear.Height) / 6
Next
End Sub
Private Sub InitCalendar()
On Error Resume Next
msfMonth.Row = 0
For ColCount = 0 To 6
msfMonth.Col = ColCount
msfMonth.CellAlignment = 4
msfMonth.CellFontSize = 10
msfMonth.CellForeColor = RGB(100, 100, 100)
Select Case ColCount
Case 0
msfMonth.Text = "星期一"
Case 1
msfMonth.Text = "星期二"
Case 2
msfMonth.Text = "星期三"
Case 3
msfMonth.Text = "星期四"
Case 4
msfMonth.Text = "星期五"
Case 5
msfMonth.Text = "星期六"
Case 6
msfMonth.Text = "星期天"
End Select
Next
End Sub
Private Sub FillCalendar(actDate As Date)
On Error Resume Next
Dim FirstDayOfMonth As Integer
Dim MonthDayCount As Integer
Dim actRow As Integer
Dim actCol As Integer
Dim DayCount As Integer
Dim actDay As Integer
Dim thisDay As Integer
Dim dumDate As Date
msfMonth.Clear
InitCalendar
ClearDayArray
dumDate = actDate
Do While Month(actDate) = Month(dumDate)
dumDate = dumDate + 1
Loop
dumDate = dumDate - 1
MonthDayCount = Day(dumDate)
m_DaysOfMonth = MonthDayCount
dumDate = actDate
Do While Month(actDate) = Month(dumDate)
dumDate = dumDate - 1
Loop
dumDate = dumDate + 1
FirstDayOfMonth = Weekday(dumDate)
If FirstDayOfMonth = 1 Then
FirstDayOfMonth = 7
Else
FirstDayOfMonth = FirstDayOfMonth - 1
End If
actCol = FirstDayOfMonth - 1
msfMonth.Row = 1
For DayCount = 1 To MonthDayCount
With msfMonth
.Col = actCol
'Dem ArrayFeld wird ein Wert zugeordnet ...
DayArray(DayCount - 1) = (msfMonth.Row - 1) * 7 + (actCol + 1)
.Text = DayCount
.CellAlignment = 0
If actCol = 6 Then
.CellForeColor = RGB(25, 150, 135)
Else
.CellForeColor = RGB(110, 110, 110)
End If
actCol = actCol + 1
If actCol = 7 Then
actCol = 0
.Row = .Row + 1
End If
End With
Next
If Month(m_DateValue) = Month(DateTime.Date) And _
Year(m_DateValue) = Year(DateTime.Date) Then
thisDay = Day(DateTime.Date)
If DayArray(thisDay - 1) Mod 7 = 0 Then
actCol = 6
actRow = DayArray(thisDay - 1) \ 7
Else
actCol = (DayArray(thisDay - 1) Mod 7) - 1
actRow = (DayArray(thisDay - 1) \ 7) + 1
End If
With msfMonth
.Row = actRow
.Col = actCol
Set .CellPicture = imgToday.Picture
.CellPictureAlignment = 8
End With
End If
actDay = Day(m_DateValue)
If DayArray(actDay - 1) Mod 7 = 0 Then
actCol = 6
actRow = DayArray(actDay - 1) \ 7
Else
actCol = (DayArray(actDay - 1) Mod 7) - 1
actRow = (DayArray(actDay - 1) \ 7) + 1
End If
With msfMonth
.Row = actRow
.Col = actCol
End With
msfMonth.Refresh
End Sub
Private Sub UpdateTitleLabel()
lblMonthYear.Caption = Format(m_DateValue, "MMMM") & ", " & Format(m_DateValue, "YYYY")
End Sub
Public Property Get DateValue() As Date
Attribute DateValue.VB_Description = "Gibt das aktuell, eingestellte Datum wieder."
DateValue = m_DateValue
End Property
Public Property Let DateValue(ByVal vDateValue As Date)
If IsDate(vDateValue) Then
m_DateValue = vDateValue
Else
m_DateValue = DateTime.Date
End If
PropertyChanged "DateValue"
FillCalendar m_DateValue
UpdateTitleLabel
RaiseEvent DateChanged(m_DateValue)
End Property
Public Property Get DaysOfMonth() As Integer
DaysOfMonth = m_DaysOfMonth
End Property
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
PropBag.WriteProperty "DateValue", m_DateValue, DateTime.Date
End Sub
Private Sub ClearDayArray()
Dim i As Byte
For i = 0 To 30
DayArray(i) = 0
Next
End Sub
Public Sub SetSingleDate(DayNumber As Integer)
SetReset DayNumber, 0
End Sub
Public Sub ResetSingleDate(DayNumber As Integer)
SetReset DayNumber, 1
End Sub
Public Sub SetDates(DateArray() As Integer, ElementCount As Integer)
On Error Resume Next
Dim CurElement As Integer
If ElementCount > 0 And ElementCount <= 31 Then
For CurElement = 0 To ElementCount - 1
SetReset DateArray(CurElement), 0
Next
End If
End Sub
Public Sub ResetDates(DateArray() As Integer, ElementCount As Integer)
On Error Resume Next
Dim CurElement As Integer
If ElementCount > 0 And ElementCount <= 31 Then
For CurElement = 0 To ElementCount - 1
SetReset DateArray(CurElement), 1
Next
End If
End Sub
Private Sub SetReset(DayNumber As Integer, Mode As Byte)
On Error Resume Next
Dim oldRow As Integer
Dim oldCol As Integer
Dim actRow As Integer
Dim actCol As Integer
If DayNumber >= 1 And DayNumber <= 31 Then
If DayArray(DayNumber - 1) > 0 Then
With msfMonth
oldRow = .Row
oldCol = .Col
End With
If DayArray(DayNumber - 1) Mod 7 = 0 Then
actRow = DayArray(DayNumber - 1) \ 7
actCol = 6
Else
actRow = (DayArray(DayNumber - 1) \ 7) + 1
actCol = (DayArray(DayNumber - 1) Mod 7) - 1
End If
With msfMonth
.Row = actRow
.Col = actCol
If Mode = 0 Then
If .CellPicture = 0 Then _
Set .CellPicture = imgDate.Picture
ElseIf Mode = 1 Then
If Not .CellPicture Is imgToday.Picture Then _
Set .CellPicture = Nothing
End If
.CellPictureAlignment = 8
.Row = oldRow
.Col = oldCol
End With
End If
End If
End Sub
Public Function IsDateSet(DayNumber As Integer) As Boolean
On Error Resume Next
Dim oldRow As Integer
Dim oldCol As Integer
Dim actRow As Integer
Dim actCol As Integer
IsDateSet = False
If DayNumber >= 1 And DayNumber <= 31 Then
With msfMonth
oldRow = .Row
oldCol = .Col
End With
If DayArray(DayNumber - 1) Mod 7 = 0 Then
actRow = DayArray(DayNumber - 1) \ 7
actCol = 6
Else
actRow = (DayArray(DayNumber - 1) \ 7) + 1
actCol = (DayArray(DayNumber - 1) Mod 7) - 1
End If
With msfMonth
.Row = actRow
.Col = actCol
If .CellPicture <> 0 Then _
IsDateSet = True
.Row = oldRow
.Col = oldCol
End With
End If
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -