www.pudn.com > 考勤管理系统源码(VB含串口接口程序).zip > frmRiLi.frm
VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Object = "{FE0065C0-1B7B-11CF-9D53-00AA003C9CB6}#1.1#0"; "COMCT232.OCX"
Begin VB.Form frmRiLi
BorderStyle = 3 'Fixed Dialog
Caption = "日历"
ClientHeight = 2985
ClientLeft = 45
ClientTop = 330
ClientWidth = 4485
ControlBox = 0 'False
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmRiLi.frx":0000
KeyPreview = -1 'True
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 2985
ScaleWidth = 4485
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton Command1
Caption = "确定(&K)"
Height = 435
Left = 3120
TabIndex = 3
Top = 75
Width = 1275
End
Begin VB.PictureBox PicMonth
BackColor = &H00FFFFFF&
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 405
Left = 1665
ScaleHeight = 345
ScaleWidth = 810
TabIndex = 5
Top = 90
Width = 870
Begin ComCtl2.UpDown VScrollMonth
Height = 360
Left = 540
TabIndex = 10
Top = -15
Width = 270
_ExtentX = 476
_ExtentY = 635
_Version = 327681
BuddyControl = "txtMonth"
BuddyDispid = 196611
OrigLeft = 540
OrigRight = 810
OrigBottom = 360
SyncBuddy = -1 'True
Wrap = -1 'True
BuddyProperty = 65547
Enabled = -1 'True
End
Begin VB.TextBox txtMonth
Alignment = 2 'Center
Appearance = 0 'Flat
BorderStyle = 0 'None
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
Left = 60
MaxLength = 2
TabIndex = 2
Text = "3"
Top = 60
Width = 420
End
End
Begin VB.PictureBox picYear
BackColor = &H00FFFFFF&
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 405
Left = 105
ScaleHeight = 345
ScaleWidth = 1080
TabIndex = 4
Top = 90
Width = 1140
Begin ComCtl2.UpDown VScrollYear
Height = 375
Left = 810
TabIndex = 9
Top = -15
Width = 270
_ExtentX = 476
_ExtentY = 661
_Version = 327681
BuddyControl = "txtYear"
BuddyDispid = 196613
OrigLeft = 810
OrigTop = 15
OrigRight = 1080
OrigBottom = 390
SyncBuddy = -1 'True
Wrap = -1 'True
BuddyProperty = 65547
Enabled = -1 'True
End
Begin VB.TextBox txtYear
Alignment = 2 'Center
Appearance = 0 'Flat
BorderStyle = 0 'None
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
Left = 105
MaxLength = 4
TabIndex = 1
Text = "2000"
Top = 45
Width = 555
End
End
Begin MSFlexGridLib.MSFlexGrid msfGrid
Height = 2400
Left = 0
TabIndex = 0
Top = 615
Width = 4485
_ExtentX = 7911
_ExtentY = 4233
_Version = 393216
Rows = 7
Cols = 7
FixedCols = 0
BackColorFixed = 12648447
ForeColorFixed = 192
BackColorSel = 12582912
AllowBigSelection= 0 'False
TextStyleFixed = 3
HighLight = 0
FillStyle = 1
ScrollBars = 0
FormatString = "dddd"
End
Begin VB.TextBox txtFocus
Height = 315
Left = 1470
TabIndex = 8
Text = "Text1"
Top = 1830
Width = 855
End
Begin VB.Label Label2
AutoSize = -1 'True
BackColor = &H00C0C0C0&
Caption = "月"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Left = 2580
TabIndex = 7
Top = 195
Width = 240
End
Begin VB.Label Label1
AutoSize = -1 'True
BackColor = &H00C0C0C0&
Caption = "年"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Left = 1365
TabIndex = 6
Top = 195
Width = 240
End
End
Attribute VB_Name = "frmRiLi"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public mRetDate As String
Dim mOldRow As Integer
Dim mOldCol As Integer
Dim mCurDay As Integer
Dim misToCheckMouse As Boolean '是否检查mouserow,mousecol
Dim misRefresh As Boolean '要不要刷新行和列,在RefreshDayList更换行列时 不misrefresh=false
Dim misStart As Boolean '判断是否刚开始,开始的时候不刷新RefreshDayList
Dim mSelDate As Integer '选择的日期
Private Sub Command1_Click()
' Dim tmpDate As String
' Select Case Trim(Me.Tag)
' Case UCase("frmMain")
' tmpDate = getDate
' frmMain.mRetDate = tmpDate
' End Select
mRetDate = getDate
Me.Hide
End Sub
Private Function getDate() As String
getDate = Format(DateSerial(Val(txtYear), Val(txtMonth), _
Val(msfGrid.TextMatrix(msfGrid.row, msfGrid.col))), _
"yyyy-mm-dd")
End Function
Private Sub Form_Activate()
misToCheckMouse = False
misRefresh = False
misStart = True
mSelDate = Day(Date)
mCurDay = mSelDate 'Day(Date)
txtYear = Year(Date)
txtMonth = Month(Date)
IniVscroll
iniGrid
misStart = False
RefreshDayList
End Sub
Private Sub IniVscroll()
With VScrollYear
.Max = 9999
.Min = 1919
.Increment = 1
'.SmallChange = 1
.Value = Year(Date)
End With
With VScrollMonth
.Max = 12
.Min = 1
'.LargeChange = 1
.Increment = 1
.Value = Month(Date)
End With
End Sub
Private Sub iniGrid()
With msfGrid
.Rows = 7
.Cols = 7
.FixedRows = 1
.FixedCols = 0
.Height = 2406
.Width = 4480
.BackColorFixed = &HC0E0FF
.BackColorSel = &H8000000D 'vbWhite
.ForeColorSel = vbWhite
.BackColorBkg = &H8000000E
.ForeColorFixed = &HC0& '&HFF&
.FormatString = "^日" & vbTab _
& "^一" & vbTab _
& "^二" & vbTab _
& "^三" & vbTab _
& "^四" & vbTab _
& "^五" & vbTab _
& "^六" & vbTab
Dim I As Integer
For I = 0 To .Rows - 1
If I = 0 Then
.RowHeight(I) = 336
Else
.RowHeight(I) = 336
End If
Next
For I = 0 To .Cols - 1
.ColWidth(I) = 625
Next
End With
End Sub
'Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
' If UnloadMode = vbFormControlMenu Then
' Select Case Trim(Me.Tag)
' Case UCase("frmMain")
' frmMain.mRetDate = getDate
' End Select
' End If
'End Sub
Private Sub msfGrid_Click()
With msfGrid
If Trim(.TextMatrix(.row, .col)) <> Empty Then
mSelDate = Val(.TextMatrix(.row, .col))
End If
End With
End Sub
Private Sub RefreshDayList()
Dim MaxDay As Integer
Dim FirstWeekDay As Integer
Dim DayRow As Integer
Dim DayCol As Integer
Dim I As Integer
With msfGrid
If Trim(txtYear) <> Empty And Trim(txtMonth) <> Empty Then
MaxDay = GetMaxDayInAMonth(Val(txtYear), Val(txtMonth))
FirstWeekDay = Weekday(DateSerial(Val(txtYear), Val(txtMonth), 1))
DayRow = 1
DayCol = FirstWeekDay - 1
For I = 0 To DayCol - 1
'.TextArray(DayRow * 7 + i) = ""
.TextArray(faIndex(DayRow, I)) = ""
Next I
.Cols = 7
.Rows = 7
setGridText DayCol, 1, MaxDay, False, msfGrid
setGridText DayCol, MaxDay + 1, (.Rows) * (.Cols - 1), True, msfGrid
mCurDay = mSelDate ' Day(Date)
If mCurDay > MaxDay Then
mCurDay = MaxDay
End If
Dim myRow As Integer
Dim myCol As Integer
myCol = (DayCol + mCurDay) Mod .Cols
myRow = ((DayCol + mCurDay) \ .Cols) + 1
If myCol = 0 Then
myCol = 6
myRow = myRow - 1
Else
myCol = myCol - 1
myRow = myRow
End If
If myRow > 0 Then
If .Redraw Then .Redraw = False
misRefresh = True
mOldRow = myRow
mOldCol = myCol
.row = myRow
.col = myCol
' misRefresh = False
If Not .Redraw Then .Redraw = True
End If
End If
End With
End Sub
Private Sub setGridText(DayCol As Integer, StartDay As Integer, EndDay As Integer, isEmpty As Boolean, msfGrid As MSFlexGrid)
Dim I As Integer
Dim myRow As Integer
Dim myCol As Integer
With msfGrid
For I = StartDay To EndDay
myCol = (DayCol + I) Mod .Cols
myRow = ((I + DayCol) \ .Cols) + 1
If myRow > .Rows - 1 Then Exit For
If myCol = 0 Then
myCol = 6
myRow = myRow - 1
Else
myCol = myCol - 1
myRow = myRow
End If
Dim tmpStr As String
If isEmpty Then
tmpStr = Empty
Else
tmpStr = I
End If
.TextArray(faIndex(myRow, myCol)) = tmpStr
Next
End With
End Sub
Private Sub msfGrid_DblClick()
Command1_Click
End Sub
Private Sub msfGrid_EnterCell()
With msfGrid
.CellBackColor = vbBlue
.CellForeColor = vbWhite
End With
End Sub
Private Sub msfGrid_GotFocus()
misToCheckMouse = True
End Sub
Private Sub msfGrid_LeaveCell()
With msfGrid
.CellBackColor = vbWhite
.CellForeColor = vbBlack
End With
End Sub
Private Sub msfGrid_LostFocus()
misToCheckMouse = False
With msfGrid
mOldRow = .row
mOldCol = .col
End With
misRefresh = False
End Sub
Private Sub msfGrid_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
With msfGrid
.row = .row
.col = .col
.RowSel = .row
.ColSel = .col
End With
End Sub
Private Sub msfGrid_SelChange()
With msfGrid
Dim myRow As Integer
Dim myCol As Integer
If Trim(.TextMatrix(.row, .col)) = Empty Then
'If .Redraw Then .Redraw = False
.row = mOldRow
.col = mOldCol
If .Redraw Then .Redraw = False
Else
'If Not .Redraw Then .Redraw = True
mSelDate = Val(.TextMatrix(.row, .col))
End If
If misToCheckMouse Then
myRow = .MouseRow
myCol = .MouseCol
Else
If Not misRefresh Then
myRow = mOldRow
myCol = mOldCol
.row = mOldRow
.col = mOldCol
Else
myRow = .row
myCol = .col
End If
End If
If myRow = 0 Then 'Or Trim(.TextMatrix(myRow, myCol)) = Empty Then 'If .MouseRow = 0 Or Trim(.TextMatrix(.MouseRow, .MouseCol)) = Empty Then
.row = mOldRow
.col = mOldCol
If .Redraw Then .Redraw = False
Else
mOldRow = .row
mOldCol = .col
If Not .Redraw Then .Redraw = True
End If
End With
End Sub
Private Sub txtMonth_Change()
If Trim(txtMonth) = Empty Then Exit Sub
' VScrollMonth.Value = Val(txtMonth.Text)
If Not misStart Then
RefreshDayList
End If
End Sub
Private Sub txtMonth_GotFocus()
GotFocus txtMonth
End Sub
Private Sub txtMonth_KeyDown(KeyCode As Integer, Shift As Integer)
With VScrollMonth
Select Case KeyCode
Case 13
If (Val(txtMonth) >= .Min) And (Val(txtMonth) <= .Max) Then
SendKeyTab KeyCode
End If
Case vbKeyUp
If Val(txtMonth) < .Max Then txtMonth = Val(txtMonth) + 1
Case vbKeyDown
If Val(txtMonth) > .Min Then txtMonth = Val(txtMonth) - 1
End Select
End With
End Sub
Private Sub txtMonth_KeyPress(KeyAscii As Integer)
KeyAscii = ValiText(KeyAscii, "123456789", True)
End Sub
Private Sub txtYear_Change()
If Len(Trim(txtYear)) < 4 Then Exit Sub
' VScrollYear.Value = Val(txtYear.Text)
If Not misStart Then
RefreshDayList
End If
End Sub
Private Sub txtYear_GotFocus()
GotFocus txtYear
End Sub
Private Sub txtYear_KeyDown(KeyCode As Integer, Shift As Integer)
With VScrollYear
Select Case KeyCode
Case 13
If (Val(txtYear) >= .Min) And (Val(txtYear) <= .Max) Then
SendKeyTab KeyCode
End If
Case vbKeyUp
If Val(txtYear) < .Max Then txtYear = Val(txtYear) + 1
Case vbKeyDown
If Val(txtYear) > .Min Then txtYear = Val(txtYear) - 1
End Select
End With
End Sub
Private Sub txtYear_KeyPress(KeyAscii As Integer)
KeyAscii = ValiText(KeyAscii, "0123456789", True)
End Sub
Private Sub VScrollMonth_Change()
' txtMonth = VScrollMonth.Value
End Sub
Private Sub VScrollYear_Change()
' txtYear = VScrollYear.Value
End Sub
Function faIndex(row As Integer, col As Integer) As Long
faIndex = row * msfGrid.Cols + col
End Function