main.frm

这是一个排课的管理系统

 MsgBox "系统目前支持每天的课数为6节，因此您需要输入6个时间段！", vbInformation, "提示"
 kctable = "教学时间段"
 Form5.Show 1
 End If
 Do While Not kc2.EOF
 Grid5.Cell(i, 0).Text = kc2.Fields(0)
 i = i + 1
 kc2.MoveNext
 Loop
 XPPbr1.Visible = False
 If admin = False Then
 XPButton2.Enabled = False
 XPButton4.Enabled = False
 XPButton1.Enabled = False
 XPButton6.Enabled = False
 savebutton.Enabled = False
 editbutton.Enabled = False
 delbutton.Enabled = False
 asPopup5.Enabled = False
 asPopup10.Enabled = False
 asPopup4.Enabled = False
 asPopup2.Enabled = False
 asPopup1.Enabled = False
 End If
 Exit Sub
finish:
MsgBox Err.Description
 End Sub
Private Sub grid2pz()
On Error GoTo finish
Grid2.ReadOnly = True
Grid2.Column(0).Width = 0
Grid2.RowHeight(0) = 0
Grid2.Cols = (7 * nknumber) + 1
For i = 1 To Grid2.Cols - 1
Grid2.Column(i).Width = 20
Next
Grid2.Range(1, 1, Grid2.Rows - 1, Grid2.Cols - 1).BackColor = RGB(90, 158, 214)
Exit Sub
finish:
MsgBox Err.Description
End Sub
Private Sub grid3pz()
On Error GoTo finish
Grid3.ReadOnly = True
Grid3.Column(0).Width = 0
Grid3.RowHeight(0) = 0
Grid3.Cols = (7 * nknumber) + 1
For i = 1 To Grid3.Cols - 1
Grid3.Column(i).Width = 20
Next
Grid3.Range(1, 1, Grid3.Rows - 1, Grid3.Cols - 1).BackColor = RGB(90, 158, 214)
Exit Sub
finish:
MsgBox Err.Description
End Sub
Private Sub kcmge()
On Error GoTo finish
 kctable = "课程信息"
 numberkc = 7
 Set kc1 = cnn.Execute("select * from " & kctable & " where 所属班级='" & XPCombo1.Text & "' order by 每周课数 asc")
 For i = 1 To numberkc
 Grid1.Cell(0, i).Text = kc1.Fields(i - 1).Name
 Next
 i = 1
 Grid1.Rows = 1
 Do While Not kc1.EOF
 Grid1.Rows = Grid1.Rows + 1
 For j = 1 To numberkc '设定读取列
 If Not kc1.Fields(j - 1) Is Nothing Then '空值的处理
  Grid1.Cell(i, j).Text = kc1.Fields(j - 1)
 Else
 Grid2.Cell(i, j).Text = ""
 End If
 Next
 kc1.MoveNext '读取下一记录
 i = i + 1
Loop
Exit Sub
finish:
MsgBox Err.Description
End Sub

Private Sub Grid1_CellChange(ByVal Row As Long, ByVal Col As Long)
On Error GoTo finish
If kcsave = False Then
 savebutton.Enabled = False
Else
 savebutton.Enabled = True
End If
If kcedit = False Then
 editbutton.Enabled = False
Else
 editbutton.Enabled = True
End If
If kcdel = False Then
 delbutton.Enabled = False
Else
 delbutton.Enabled = True
End If
If Grid1.Cell(Row, 2).Text <> "" And Grid1.Cell(Row, 3).Text <> "" And Row <> 0 Then
Grid1.Cell(Row, 4).Text = Int((Grid1.Cell(Row, 2).Text) / (Grid1.Cell(Row, 3).Text))
End If
Exit Sub
finish:
MsgBox Err.Description
End Sub

Private Sub Grid1_RowColChange(ByVal Row As Long, ByVal Col As Long)
On Error GoTo finish
hang = Row
If Grid1.Cell(Row, 1).Text <> "" Then
Grid1.ComboBox(5).Clear
Set kc2 = cnn.Execute("SELECT DISTINCT 教师姓名 FROM 课程名 where 课程名='" & Grid1.Cell(Row, 1).Text & "'")
Do While Not kc2.EOF
Grid1.ComboBox(5).AddItem kc2.Fields(0)
kc2.MoveNext
Loop
End If
Exit Sub
finish:
MsgBox Err.Description
End Sub

Private Sub Grid5_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If dkyesno = True And Button = 2 Then
PopupMenu dk
End If
End Sub

Private Sub Grid5_RowColChange(ByVal Row As Long, ByVal Col As Long)
hang1 = Row
ne1 = Col
End Sub

Private Sub playwz_Click()
MsgBox "执行此处请参照完整版EXE程序"
End Sub

Private Sub savebutton_Click()
On Error GoTo finish
If XPCombo1.Text = "" Then
MsgBox "班级名称不可为空，请选择班级", vbInformation, "提示"
End If
word_validate
If vde = False Then
 MsgBox "因已生成课程表，为不可操作状态，请注销现有的课程表在进行操作！", vbInformation, "提示"
 Exit Sub
End If
If kcsave = False Then
MsgBox "当前不允许保存！", vbInformation, "提示"
Exit Sub
End If
For i = 1 To Grid1.Rows - 1 '处理重名数据
 If Grid1.Cell(i, 1).Text <> "" Then
 Set kc1 = cnn.Execute("select 课程名 from 课程信息 where 课程名='" & Grid1.Cell(i, 1).Text & "' and 所属班级='" & XPCombo1.Text & "'")
 If kc1.EOF = False Then
   MsgBox "第" & i & "行的课程名在数据库里出现重复，请检查", vbInformation, "错误"
   Grid1.Cell(i, 1).SetFocus
   Exit Sub
 End If
 End If
Next
For i = 1 To Grid1.Rows - 1
  For n = 1 To Grid1.Cols - 1
    Select Case n
       Case 1, 2, 3, 4, 5, 7 '检查数据是否为空
         If Grid1.Cell(i, 1).Text <> "" Then
          If Grid1.Cell(i, n).Text = "" Then
            MsgBox "第" & i & "行的--[" & Grid1.Cell(0, n).Text & "]--字段不允许为空!", vbInformation, "提示"
            Grid1.Cell(i, n).SetFocus
            Exit Sub
          End If
          If Grid1.Cell(i, 3).Text < "2" And Grid1.Cell(i, 6).Text = "1" Then
            MsgBox "第" & i & "行的每周课数无法实现两节课连排!", vbInformation, "提示"
          Exit Sub
          End If
          ElseIf i = 1 Then
          MsgBox "无任何数据可保存", vbInformation, "排课系统"
          Exit Sub
          End If
    End Select
    Next
  If Grid1.Cell(i, 1).Text <> "" Then '执行插入语句
  sql = "insert into 课程信息 values('"
            For j = 1 To Grid1.Cols - 1
            sql = sql & Grid1.Cell(i, j).Text & "','"
           Next
  sql = sql & XPCombo1.Text & "')"
  Set kc1 = cnn.Execute(sql)
  End If
Next
MsgBox "命令执行完毕!", vbInformation, "完成"
Call XPButton3_Click
Exit Sub
finish:
MsgBox Err.Description
End Sub

Private Sub XPButton1_Click()
On Error GoTo finish
If XPCombo1.Text = "" Then
MsgBox "班级名称不可为空，请选择班级", vbInformation, "提示"
End If
word_validate
If vde = False Then
 MsgBox "因已生成课程表，为不可操作状态，请注销现有的课程表在进行操作！", vbInformation, "提示"
 Exit Sub
End If
Grid1.Visible = True
 kctable = "课程信息"
 numberkc = 7
 Set kc1 = cnn.Execute("select * from " & kctable)
 For i = 1 To numberkc
 Grid1.Cell(0, i).Text = kc1.Fields(i - 1).Name
 Next
 Grid1.Rows = 1
Grid1.Rows = 8
gridcenter
Grid1.Cell(1, 1).SetFocus
griddispose
kcsave = True
kcedit = False
kcdel = False
Exit Sub
finish:
MsgBox Err.Description
End Sub
Private Sub gridcenter()
If Grid1.Rows <> 1 Then
Grid1.Range(1, 1, Grid1.Rows - 1, Grid1.Cols - 1).Alignment = cellCenterCenter
End If
End Sub
Private Sub griddispose()
On Error GoTo finish
Grid1.Column(1).CellType = cellComboBox
Grid1.Column(5).CellType = cellComboBox
Grid1.Column(6).CellType = cellCheckBox
Grid1.Column(7).CellType = cellComboBox
Grid1.ComboBox(1).Clear
Set kc2 = cnn.Execute("SELECT DISTINCT 课程名 FROM 课程名")
Do While Not kc2.EOF
Grid1.ComboBox(1).AddItem kc2.Fields(0)
kc2.MoveNext
Loop
Grid1.ComboBox(7).Clear
Grid1.ComboBox(7).AddItem "周一至周五"
Grid1.ComboBox(7).AddItem "周一至周六"
Grid1.ComboBox(7).AddItem "周一至周日"
Exit Sub
finish:
MsgBox Err.Description
End Sub

Private Sub XPButton2_Click()
MsgBox "执行此处请参照完整版EXE程序"
End Sub


Private Sub XPButton3_Click()
On Error GoTo finish
If XPCombo1.Text = "" Then
MsgBox "班级名称不可为空，请选择班级", vbInformation, "提示"
End If
Grid1.Visible = True
kcsave = False
kcedit = True
kcdel = True
griddispose
kcmge
gridcenter
Exit Sub
finish:
MsgBox Err.Description
End Sub

Private Sub kbreturn()
MsgBox "执行此处请参照完整版EXE程序"
End Sub

Private Sub XPButton4_Click()
If XPCombo1.Text = "" Then
MsgBox "班级名称不可为空，请选择班级", vbInformation, "提示"
End If
Call XPButton3_Click
kbreturn
End Sub

Private Sub XPButton5_Click()
On Error GoTo finish
If XPCombo1.Text = "" Then
MsgBox "班级名称不可为空，请选择班级", vbInformation, "提示"
End If
Set xlApp = CreateObject("Excel.Application")
'激活EXCEL应用程序
xlApp.Visible = False '隐藏EXCEL应用程序窗口
'打开工作簿，strDestination为一个EXCEL报表文件
 '设定工作表
Dim strSource, strDestination As String
 strSource = App.path & "\Excels\bak.xls"
'RegisterFee.xls就是一个模版文件
 strDestination = App.path & "\Excels\temp.xls"
  FileCopy strSource, strDestination
  Set xlbook = xlApp.Workbooks.Open(strDestination)
  Set xlSheet = xlbook.Worksheets(1)
 '将模版文件拷贝到一个临时文件
  sendsql = "select 时间段,星期一,星期二,星期三,星期四,星期五,星期六,星期日,所属班级 from 临时生成表 where 所属班级='" & XPCombo1.Text & "' order by 自动编号 asc"
  Set kc2 = cnn.Execute(sendsql)
  xlSheet.Cells(1, 1) = XPCombo1.Text & "课程表"
  For i = 5 To 8
    For j = 1 To 8
      xlSheet.Cells(i, j) = kc2.Fields(j - 1)
    Next
    kc2.MoveNext
  Next
  For i = 10 To 13
   If kc2.EOF = True Then
   Exit For
   End If
    For j = 1 To 8
       xlSheet.Cells(i, j) = kc2.Fields(j - 1)
    Next
    kc2.MoveNext
  Next
  xlbook.Save
  Dim vyes As String
  vyes = MsgBox("是否打印导出的课程表内容？", vbQuestion + vbYesNo, "是否打印？")
  If vyes = vbYes Then
  If Printers.Count <= 0 Then
  MsgBox "没有安装打印机", , "错误"
  xlApp.Quit
  Exit Sub
  End If
  xlSheet.PrintOut '有打印机就可使用
  End If
  xlApp.Quit
  Exit Sub
finish:
MsgBox Err.Description
End Sub
Private Sub XPButton6_Click()
If kcsave = True Then
Grid1.Rows = Grid1.Rows + 1
Else
MsgBox "非添加状态不可添加新行", vbInformation, "不可操作"
End If
End Sub

Private Sub XPButton7_Click()
On Error GoTo finish
If XPCombo1.Text = "" Then
MsgBox "班级名称不可为空，请选择班级", vbInformation, "提示"
End If
sendsql = "select 时间段,星期一,星期二,星期三,星期四,星期五,星期六,星期日,所属班级 from 临时生成表 where 所属班级='" & XPCombo1.Text & "' order by 自动编号 asc"
MDIForm1.WindowState = 2
Classprint.rsDK1 sendsql
ClassReport.Show
Set ClassReport.DataSource = Classprint.rs1
Exit Sub
finish:
MsgBox Err.Description
End Sub

Private Sub XPButton8_Click()
On Error GoTo finish
If XPCombo1.Text = "" Then
MsgBox "班级名称不可为空，请选择班级", vbInformation, "提示"
End If
dkyesno = True
  Grid5.Range(1, 1, Grid5.Rows - 1, Grid5.Cols - 1).ClearText
  sendsql = "select 星期一,星期二,星期三,星期四,星期五,星期六,星期日,所属班级 from 临时生成表 where 所属班级='" & XPCombo1.Text & "' order by 自动编号 asc"
  Set kc2 = cnn.Execute(sendsql)
  If kc2.EOF = True Then
  Exit Sub
  End If
  For i = 1 To 6
    For j = 1 To 7
     Grid5.Cell(i, j).Text = kc2.Fields(j - 1)
    Next
    kc2.MoveNext
  Next
Exit Sub
finish:
MsgBox Err.Description
End Sub