VB6.0 写的日历类模块

来源：互联网发布：cocos2d js 教程 mac 编辑：程序博客网时间：2024/05/17 06:15

------钅隼戋

新建一个类模块，将源代码复制进去。

在Form上添加一个PictureBox控件

Form中添加一个公共变量指向 “类 “ 用 Init_Class 过程初始化

运行后的日历界面效果：

源代码：

Public Value As Date
'======================================================================================
Dim WithEvents PAD As PictureBox
Dim DateSel() As Integer
Dim DateVal() As Date
Dim Days As Integer
'-------------------------------------------------
Dim ClickSel As Integer
'***************************************************************************************
Public Sub Init_Class(ByRef Draw_Picture As PictureBox, X As Integer, Y As Integer)
Set PAD = Draw_Picture
PAD.Parent.ScaleMode = 3
With PAD
.AutoRedraw = True
.ScaleMode = 3
.BorderStyle = 0
.Left = X
.Top = Y
.Width = 200
.Height = 165
.BackColor = RGB(79, 79, 79)
End With
Value = Now
Draw_PAD
End Sub

Private Sub Draw_PAD()
PAD.Cls
Dim DS As Date, DE As Date
Dim Ww As Integer, StepW As Integer, STR As String
Dim CellW As Integer, I As Integer
Value = CDate(Format(Value, "yyyy/mm/dd"))
DS = Format(Value, "yyyy/mm") & "/1": DS = DS - DatePart("W", DS, vbMonday) + 1
DE = DateAdd("M", 1, CDate(Format(Value, "yyyy/mm") & "/1")) - 1
DE = DE + 7 - DatePart("W", DE, vbMonday)
'PAD.Scale (0, 0)-(PAD.Width, PAD.Height)
'--------------------------------------------
With PAD
.FontSize = 10
.FontBold = True
.ForeColor = RGB(255, 255, 255)
.CurrentX = 10
.CurrentY = 7
End With
PAD.Print Format(Value, "YYYY年MM月DD日") & " 第" & DatePart("ww", Value, vbMonday) & "周"
PAD.DrawWidth = 2
PAD.Line (3, 25)-(PAD.Width - 3, 25), RGB(255, 255, 255), BF
PAD.FontSize = 8
CellW = (PAD.Width - 6) / 7
For I = 1 To 7
STR = "周" & Choose(I, "一", "二", "三", "四", "五", "六", "日")
PAD.CurrentX = CellW * (I - 1) + 3 + (CellW - PAD.TextWidth(STR)) / 2
PAD.CurrentY = 30
PAD.Print STR
Next
'---------------------------------------------
PAD.FontBold = False
PAD.DrawWidth = 1
Ww = DateDiff("ww", DS, DE)
StepW = 85 / Ww
Dim Cy As Integer, Dn As Integer
Dim Pday As Date
Cy = 47
Days = DE - DS
ReDim DateSel(1 To 5, Days + 3) As Integer
ReDim DateVal(Days) As Date
For I = 0 To Days
Pday = DS + I
DateSel(1, I) = CellW * (DatePart("W", Pday, vbMonday) - 1) + 5 'x1
DateSel(2, I) = Cy - 1 'y1
DateSel(3, I) = DateSel(1, I) + CellW - 4 'x2
DateSel(4, I) = DateSel(2, I) + PAD.TextHeight("9") + 2 'y2
DateSel(5, I) = 1 '1 日期 | 2 跳到今天 | 3 向前一个月 | 4 向后一个月
If Pday = Value Then
PAD.Line (DateSel(1, I), DateSel(2, I))- _
(DateSel(3, I), DateSel(4, I)), RGB(200, 50, 40), BF
End If
PAD.CurrentX = CellW * (DatePart("W", Pday, vbMonday) - 1) + 3 + (CellW - PAD.TextWidth(Day(Pday))) / 2
PAD.CurrentY = Cy
If Month(Pday) = Month(Value) Then
PAD.ForeColor = RGB(255, 255, 255)
Else
PAD.ForeColor = RGB(100, 200, 200)
End If
PAD.Print CStr(Day(Pday))
DateVal(I) = Pday
If DatePart("W", Pday, vbMonday) = 7 Then Cy = Cy + StepW
Next
'----------------------------------------------------------------------
PAD.Line (3, 135)-(PAD.Width - 3, 135), RGB(255, 255, 255), BF
PAD.DrawWidth = 2
PAD.Line (3, 160)-(PAD.Width - 3, 160), RGB(255, 255, 255), BF
PAD.ForeColor = RGB(255, 255, 255)
PAD.DrawWidth = 1
'----------------------------------------------------------------------Today
PAD.FontBold = False: PAD.FontSize = 10: PAD.FontBold = True
I = Days + 1
DateSel(1, I) = 10 'x1
DateSel(2, I) = 140 'y1
DateSel(3, I) = 60 'x2
DateSel(4, I) = 155 'y2
PAD.Line (DateSel(1, I), DateSel(2, I))- _
(DateSel(3, I), DateSel(4, I)), RGB(60, 179, 113), BF
PAD.CurrentX = (50 - PAD.TextWidth("Today")) / 2 + 10
PAD.CurrentY = 141
PAD.Print "Today"
DateSel(5, I) = 2 '1 日期 | 2 跳到今天 | 3 向前一个月 | 4 向后一个月
'----------------------------------------------------------------------Month++
PAD.FontBold = False: PAD.FontSize = 10: PAD.FontBold = True
I = Days + 2
DateSel(1, I) = 105 'x1
DateSel(2, I) = 140 'y1
DateSel(3, I) = 135 'x2
DateSel(4, I) = 155 'y2
' PAD.Line (DateSel(1, I), DateSel(2, I))- _
' (DateSel(3, I), DateSel(4, I)), RGB(60, 179, 113), B
PAD.CurrentX = (30 - PAD.TextWidth("<<<")) / 2 + 105
PAD.CurrentY = 141
PAD.Print "<<<"
DateSel(5, I) = 3 '1 日期 | 2 跳到今天 | 3 向前一个月 | 4 向后一个月
'----------------------------------------------------------------------Month--
PAD.FontBold = False: PAD.FontSize = 10: PAD.FontBold = True
I = Days + 3

DateSel(1, I) = 160 'x1
DateSel(2, I) = 140 'y1
DateSel(3, I) = 190 'x2
DateSel(4, I) = 155 'y2
' PAD.Line (DateSel(1, I), DateSel(2, I))- _
' (DateSel(3, I), DateSel(4, I)), RGB(60, 179, 113), B
PAD.CurrentX = (30 - PAD.TextWidth(">>>")) / 2 + 160
PAD.CurrentY = 141
PAD.Print ">>>"
DateSel(5, I) = 4 '1 日期 | 2 跳到今天 | 3 向前一个月 | 4 向后一个月
'-----------------------
PAD.CurrentX = 140
PAD.CurrentY = 141
PAD.Print "月"
End Sub

Private Sub PAD_Click()

If ClickSel < 0 Then Exit Sub
Select Case DateSel(5, ClickSel)
Case 1
Value = DateVal(ClickSel)
Case 2
Value = Now
Case 3
Value = DateAdd("m", -1, Value)
Case 4
Value = DateAdd("m", 1, Value)
End Select
Draw_PAD
ClickSel = -1
End Sub

Private Sub PAD_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim I As Integer, J As Integer
PAD.DrawWidth = 1
GoSub ReCover
For I = 0 To Days + 3 Step 7
If Y >= DateSel(2, I) And Y <= DateSel(4, I) Then
For J = 0 To 6
If I + J > Days + 3 Then Exit Sub
If X >= DateSel(1, I + J) And X <= DateSel(3, I + J) Then
ClickSel = I + J
PAD.Line (DateSel(1, ClickSel), DateSel(2, ClickSel))- _
(DateSel(3, ClickSel), DateSel(4, ClickSel)), RGB(255, 255, 255), B
Exit Sub
End If
Next
End If
Next
GoSub ReCover
ClickSel = -1
Exit Sub
ReCover:
If ClickSel >= 0 Then
PAD.Line (DateSel(1, ClickSel), DateSel(2, ClickSel))- _
(DateSel(3, ClickSel), DateSel(4, ClickSel)), PAD.BackColor, B
End If
Return
End Sub

0 0