bas_faccalendar_frm.frm

本代码适合初学数据库者学习借鉴

         Top             =   270
         Width           =   165
      End
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackColor       =   &H8000000A&
      Caption         =   "停工日"
      Height          =   210
      Index           =   5
      Left            =   4800
      TabIndex        =   14
      Top             =   4200
      Width           =   630
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackColor       =   &H8000000A&
      Caption         =   "休息日"
      Height          =   210
      Index           =   4
      Left            =   3000
      TabIndex        =   13
      Top             =   4200
      Width           =   630
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackColor       =   &H8000000A&
      Caption         =   "国定假日"
      Height          =   210
      Index           =   3
      Left            =   960
      TabIndex        =   12
      Top             =   4200
      Width           =   840
   End
   Begin VB.Label Label1 
      BackColor       =   &H000000FF&
      Height          =   135
      Index           =   2
      Left            =   4200
      TabIndex        =   11
      Top             =   4200
      Width           =   375
   End
   Begin VB.Label Label1 
      BackColor       =   &H00FF0000&
      Height          =   135
      Index           =   1
      Left            =   2400
      TabIndex        =   10
      Top             =   4200
      Width           =   375
   End
   Begin VB.Label Label1 
      BackColor       =   &H0000FFFF&
      Height          =   135
      Index           =   0
      Left            =   360
      TabIndex        =   9
      Top             =   4200
      Width           =   375
   End
   Begin VB.Menu Popmonth 
      Caption         =   "月份(&M)"
      Visible         =   0   'False
      Begin VB.Menu a 
         Caption         =   "一月"
         Index           =   1
      End
      Begin VB.Menu a 
         Caption         =   "二月"
         Index           =   2
      End
      Begin VB.Menu a 
         Caption         =   "三月"
         Index           =   3
      End
      Begin VB.Menu a 
         Caption         =   "四月"
         Index           =   4
      End
      Begin VB.Menu a 
         Caption         =   "五月"
         Index           =   5
      End
      Begin VB.Menu a 
         Caption         =   "六月"
         Index           =   6
      End
      Begin VB.Menu a 
         Caption         =   "七月"
         Index           =   7
      End
      Begin VB.Menu a 
         Caption         =   "八月"
         Index           =   8
      End
      Begin VB.Menu a 
         Caption         =   "九月"
         Index           =   9
      End
      Begin VB.Menu a 
         Caption         =   "十月"
         Index           =   10
      End
      Begin VB.Menu a 
         Caption         =   "十一月"
         Index           =   11
      End
      Begin VB.Menu a 
         Caption         =   "十二月"
         Index           =   12
      End
   End
End
Attribute VB_Name = "Bas_FacCalendar_Frm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim CurrentDay As Date
Dim CalDay(1 To 6, 0 To 6) As Date
Function CheckDate(TempDate As Date) As String
'检查当前日期属于什么假日

End Function


Private Sub Display()                                     '显示单元格属性及日期
Dim TempCol As Integer, TempRow As Integer
Dim Userday As Date, Fcol As Integer, i As Integer, j As Integer
Dim TempHoliday As String

Txtyear = Year(CurrentDay)
Txtmonth = Month(CurrentDay)
VScroll1.Value = Val(Txtyear)
For i = 1 To 12
    a(i).Checked = False
Next i
a(Txtmonth).Checked = True

Userday = CurrentDay
TempRow = 1
Fcol = Weekday(DateSerial(Year(Userday), Month(Userday), 1)) '本月一号是星期几

Userday = DateAdd("d", -Fcol, DateSerial(Year(Userday), Month(Userday), 1))

For i = 1 To 42
    j = i Mod 7
    If j <> 0 Then
        TempRow = i \ 7 + 1
    Else
        j = 7
        TempRow = i \ 7
    End If
    
    '判断是否休息天、国定假日、停工日等
    TempHoliday = CheckDate(DateAdd("d", i, Userday))
    
    With CalGrid
        .Cell(flexcpText, TempRow, j - 1) = Format$(DateAdd("d", i, Userday), "dd")
        If Format$(DateAdd("d", i, Userday), "m") <> Format$(CurrentDay, "m") Then
           .Cell(flexcpForeColor, TempRow, j - 1) = &H80000004
        Else
           .Cell(flexcpForeColor, TempRow, j - 1) = vbBlack
        End If
        
        CalDay(TempRow, j - 1) = DateAdd("d", i, Userday)
        
        If TempHoliday = "G" Then   '国定假日
            .Cell(flexcpBackColor, TempRow, j - 1) = vbYellow
        ElseIf TempHoliday = "S" Then   '停工日
            .Cell(flexcpBackColor, TempRow, j - 1) = vbRed
        ElseIf TempHoliday = "H" Then   '休息日
            .Cell(flexcpBackColor, TempRow, j - 1) = vbGreen
        End If
        
    End With
Next



End Sub


Sub Init()
CurrentDay = GetCurDate()  '取服务器当前日期

End Sub

Private Sub a_Click(Index As Integer)
If Index <> Txtmonth Then
   Txtmonth = Index
   CurrentDay = DateSerial(Txtyear, Txtmonth, 1)
   Display
End If
CalGrid.SetFocus

End Sub

Private Sub CalGrid_Click()
If CalGrid.Row = 0 Then Exit Sub

'判断是否点击了下一个月的日历
If Val(Format$(CalDay(CalGrid.Row, CalGrid.Col), "m")) <> Val(Txtmonth) Then
    CurrentDay = CalDay(CalGrid.Row, CalGrid.Col)
    Display
End If

End Sub

Private Sub Cndnext_Click()
CurrentDay = DateSerial(Year(CurrentDay), Month(CurrentDay) + 1, Day(CurrentDay))
Display
CalGrid.SetFocus

End Sub

Private Sub Cndpreview_Click()
CurrentDay = DateAdd("m", -1, CurrentDay)
Display
CalGrid.SetFocus

End Sub

Private Sub CndToday_Click()
CurrentDay = GetCurDate()
Display
CalGrid.SetFocus

End Sub

Private Sub Form_Load()
CurrentDay = Now
Display
End Sub

Private Sub SetCmd_Click(Index As Integer)
On Error GoTo ClickErr
Screen.MousePointer = 11

Select Case Index
    Case 0
    
    Case 1
    
    Case 2
    
    Case 3
    
    Case 4
        Unload Me
        
End Select

Screen.MousePointer = 0

Exit Sub
ClickErr:
    Screen.MousePointer = 0
    MsgBox Err.Description, vbExclamation
    
End Sub

Private Sub Txtmonth_Click()
PopupMenu Popmonth

End Sub


Private Sub VScroll1_Change()
Txtyear = VScroll1.Value
CurrentDay = DateSerial(Txtyear, Txtmonth, 1)

Display


End Sub