form2.frm

高校排课系统.这个小程序使用了皮肤控件

Private Sub GridShowValue()
  With Grid2
   If Grid4.Rows = 1 Then
   Exit Sub
   End If
   For i = 1 To .Rows - 1
    For j = 1 To .Cols - 1
     .Cell(i, j).Text = "×"
    Next
   Next
   .Range(1, 1, .Rows - 1, .Cols - 1).ForeColor = vbBlack
   For i = 1 To Grid4.Rows - 1
     x = Round(Grid4.Cell(i, 1).Text / nknumber)
     If x < Grid4.Cell(i, 1).Text / nknumber Then
     x = x + 1
     End If
     y = Grid4.Cell(i, 1).Text Mod nknumber
       If y = 0 Then
       y = nknumber
       End If
     .Cell(y, x).Text = "--"
     .Cell(y + 1, x).Text = "--"
     .Cell(y, x).ForeColor = vbBlue
     .Cell(y + 1, x).ForeColor = vbBlue
   Next
   For j = 1 To Grid1.Rows - 1 '已经手动或自动选择的但并且列入数据库的选项也需要封闭
    If Grid1.Cell(j, 9).Text <> "" Then
      Dim str1() As String
      str1 = Split(Grid1.Cell(j, 9).Text, ",")
      If UBound(str1) > 0 Then
      For i = 0 To UBound(str1)
        x = Round(str1(i) / nknumber)
       If x < str1(i) / nknumber Then
       x = x + 1
       End If
       y = str1(i) Mod nknumber
       If y = 0 Then
       y = nknumber
       End If
     .Cell(y, x).Text = "×"
     .Cell(y, x).ForeColor = vbBlack
      Next
      End If
    End If
   Next
   End With
End Sub
Private Sub Grid1_LeaveCell(ByVal Row As Long, ByVal Col As Long, NewRow As Long, NewCol As Long, Cancel As Boolean)
'单元格发生改变时事件
End Sub

Private Sub Grid1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
   ' ReleaseCapture '以下的移动方式更简便
   ' SendMessage Me.hWnd, &HA1, 2, 0&
End Sub

Private Sub Grid1_RowColChange(ByVal Row As Long, ByVal Col As Long)
hang = Row
CNumber = 1
If Row = 0 Then
Exit Sub
End If
If Grid1.Cell(Row, 8).Text = "" Then
   For i = 1 To Grid2.Rows - 1
    For j = 1 To Grid2.Cols - 1
     Grid2.Cell(i, j).Text = "×"
    Next
   Next
   Grid2.Range(1, 1, Grid2.Rows - 1, Grid2.Cols - 1).ForeColor = vbBlack
End If

If Grid1.Cell(Row, 8).Text = "手动指定" Then
      SystemAPP1 (hang) '加载资源判断过程1
      SystemAPP2 (hang) '加载资源判断过程2
      GridShowValue '显示Grid2表格值
      If Grid1.Cell(Row, 9).Text <> "" Then
       str1 = Split(Grid1.Cell(hang, 9).Text, ",")
       If UBound(str1) > 0 Then
        For i = 0 To UBound(str1)
         x = Round(str1(i) / nknumber)
         If x < str1(i) / nknumber Then
         x = x + 1
         End If
         y = str1(i) Mod nknumber
       If y = 0 Then
       y = nknumber
       End If
         Grid2.Cell(y, x).Text = "√"
         Grid2.Cell(y, x).ForeColor = vbRed
        Next
       End If
      End If
End If


With Grid1
If .Cell(Row, 8).Text = "已指定" And .Cell(Row, 9).Text <> "" Then
   Grid2.Range(1, 1, Grid2.Rows - 1, Grid2.Cols - 1).ForeColor = vbBlack
     For i = 1 To Grid2.Rows - 1
        For j = 1 To Grid2.Cols - 1
          Grid2.Cell(i, j).Text = "×"
     Next
     Next
     Set kc1 = cnn.Execute("select * from 公共教室指定 where 教室名称='" & .Cell(Row, 1).Text & "' and 班级='" & .Cell(Row, 2).Text & "' and 课程名='" & .Cell(Row, 4).Text & "'")
     str1 = Split(kc1.Fields(kc1.Fields.Count - 1), ",")
     For i = 0 To UBound(str1)
     x = Round(Int(str1(i)) / nknumber)
     If x < Int(str1(i)) / nknumber Then
     x = x + 1
     End If
     y = Int(str1(i)) Mod nknumber
     If y = 0 Then
      y = nknumber
     End If
     Grid2.Cell(y, x).Text = "√"
     Grid2.Cell(y, x).ForeColor = vbRed
     Next
End If
End With
End Sub

Private Sub Grid2_Click()
Select Case Grid2.Cell(XY_X, XY_Y).Text
 Case "--"
  If CNumber <= Grid1.Cell(hang, 5).Text Then
  Grid2.Cell(XY_X, XY_Y).Text = "√"
  Grid2.Cell(XY_X, XY_Y).ForeColor = vbRed
  CNumber = CNumber + 1
  If Grid1.Cell(hang, 9).Text = "" Then
   Grid1.Cell(hang, 9).Text = XY_N
  Else
   Grid1.Cell(hang, 9).Text = Grid1.Cell(hang, 9).Text & "," & XY_N
  End If
  TEXTCOLOR_Start
  txtRecive.SelText = txtRecive.SelText & "已选编号: " & XY_N & "---星期" & XY_Y & "---第" & XY_X & "节课-----" & vbCrLf
  TEXTCOLOR1_End
  If Grid1.Cell(hang, 6).Text = "1" Then
  TEXTCOLOR_Start
  txtRecive.SelText = txtRecive.SelText & "当前为两节课连排，请注意选择!" & vbCrLf
  TEXTCOLOR3_End
  End If
  Else
  TEXTCOLOR_Start
  txtRecive.SelText = txtRecive.SelText & "******超出选课节数范围!******" & vbCrLf
  TEXTCOLOR2_End
  End If
 Case "√"
  Dim str1() As String
  str1 = Split(Grid1.Cell(hang, 9).Text, ",")
  Grid1.Cell(hang, 9).Text = ""
  If UBound(str1) > 0 Then
  For i = 0 To UBound(str1)
   If str1(i) <> XY_N Then
    If i = 0 Then
    Grid1.Cell(hang, 9).Text = Grid1.Cell(hang, 9).Text & str1(i)
    Else
     If Grid1.Cell(hang, 9).Text <> "" Then '当用户选择第一个项目时程序判断会出现误差，因此需要判断是否需要逗号
     Grid1.Cell(hang, 9).Text = Grid1.Cell(hang, 9).Text & "," & str1(i)
     Else
     Grid1.Cell(hang, 9).Text = Grid1.Cell(hang, 9).Text & str1(i)
     End If
    End If
   End If
  Next
  End If
  Grid2.Cell(XY_X, XY_Y).Text = "--"
  Grid2.Cell(XY_X, XY_Y).ForeColor = vbBlue
  CNumber = CNumber - 1
  TEXTCOLOR_Start
  txtRecive.SelText = txtRecive.SelText & "-----已去除编号: " & XY_N & "---星期" & XY_Y & "---第" & XY_X & "节课-----" & vbCrLf
  TEXTCOLOR4_End
  If Grid1.Cell(hang, 6).Text = "1" Then
  TEXTCOLOR_Start
  txtRecive.SelText = txtRecive.SelText & "-----当前为两节课连排，请注意选择!" & vbCrLf
  TEXTCOLOR3_End
  End If
 Case "×"
End Select
Grid1.Refresh
End Sub

Private Sub Grid2_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim x1 As Integer
Dim y1 As Integer
x1 = Round((x - 40) / 30) '计算列,40为0列的宽度，30为其它列的宽
X2 = Int((x - 40) / 30)
If x1 <= X2 Or x1 = 0 Then
x1 = x1 + 1
End If
y1 = Round((y - 18) / 18) '计算行,18为各行的高度
Y2 = Int((y - 18) / 18)
If y1 <= Y2 Or y1 = 0 Then
y1 = y1 + 1
End If
If x1 = 0 Or y1 = 0 Then
Grid2.ToolTipText = ""
Else
Dim WeekStr As String
Select Case x1
 Case 1
  WeekStr = "一"
 Case 2
  WeekStr = "二"
 Case 3
  WeekStr = "三"
 Case 4
  WeekStr = "四"
 Case 5
  WeekStr = "五"
 Case 6
  WeekStr = "六"
 Case 7
  WeekStr = "日"
End Select
XY_N = ((x1 - 1) * nknumber) + y1
XY_X = y1 '行
XY_Y = x1 '列
Grid2.ToolTipText = "星期" & WeekStr & ",第" & y1 & "节课,编号(" & XY_N & ")"
End If
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
Case "提交指定"
  '先注销以前的指定
Set kc1 = cnn.Execute("select * from 公共教室指定 where 班级='" & formmain.XPCombo1.Text & "'")
If kc1.EOF = False Then
MsgBox "请先注销公共教室的指定分配！"
Exit Sub
End If
For i = 1 To Grid1.Rows - 1
 Select Case Grid1.Cell(i, 8).Text
  Case "系统生成"
    SystemMake (i)
  Case "关联指定"
    RelatSpecify (i)
  Case "手动指定"
    ManualSPecify (i)
 End Select
Next
If ErrorN = False Then '判断是否正确执行语句
For i = 1 To Grid1.Rows - 1
 Grid1.Cell(i, 8).Text = "已指定"
Next
TEXTCOLOR_Start
txtRecive.SelText = txtRecive.SelText & "--------执行成功：已经成功指定课程数据--------" & vbCrLf
TEXTCOLOR1_End
Else
ErrorN = False
TEXTCOLOR_Start
txtRecive.SelText = txtRecive.SelText & "执行失败：原因请看记录" & vbCrLf
TEXTCOLOR1_End
End If
Grid1.Refresh '刷新表格
Case "注销指定"
'注销公共课程
Dim str1() As String
Set kc1 = cnn.Execute("select * from 公共教室指定 where 班级='" & formmain.XPCombo1.Text & "'")
Do While Not kc1.EOF
 str1 = Split(kc1.Fields(kc1.Fields.Count - 1), ",")

 For i = 0 To UBound(str1)
  DeleteSpecify "课程占用", "班级", 1, str1(i)
  Set kc2 = cnn.Execute("select * from 公共教室指定 where 教室名称='" & kc1.Fields(0) & "' and 班级<>'" & kc1.Fields(1) & "' and 教师='" & kc1.Fields(2) & "' and 位置='" & kc1.Fields(kc1.Fields.Count - 1) & "'")
  If kc2.EOF = True Then
  DeleteSpecify "占用", "教师姓名", 2, str1(i)
  DeleteSpecify "公共教室", "教室名称", 0, str1(i)
  End If
 Next
 kc1.MoveNext
Loop
Set kc1 = cnn.Execute("delete from 公共教室指定 where 班级='" & formmain.XPCombo1.Text & "'")
TEXTCOLOR_Start
txtRecive.SelText = txtRecive.SelText & "注销操作：执行成功" & vbCrLf
TEXTCOLOR1_End
ShowDATA
Case "回主界面"
Unload Me
End Select
End Sub

Private Sub txtRecive_Change()
txtRecive.SelStart = Len(txtRecive.Text)
'txtRecive.SetFocus '使用此语句实现文本内容改变时光标自动调到文本尾部
End Sub

Private Sub DeleteSpecify(Updatename As String, UpdateKey As String, ByVal Col As Long, ByVal StartNumber As String)
  '注销指定占用的过程,通过参数传递
  Dim gsql As String
  Set kc2 = cnn.Execute("select 占用 from " & Updatename & " where " & UpdateKey & "='" & kc1.Fields(Col) & "'")
  gsql1 = Mid(kc2.Fields(0), 1, Int(StartNumber) - 1)
  gsql1 = gsql1 & "0"

  gsql1 = gsql1 & Mid(kc2.Fields(0), Int(StartNumber) + 1, Len(kc2.Fields(0)) - Int(StartNumber) + 1)
  Set kc2 = cnn.Execute("update " & Updatename & " set 占用='" & gsql1 & "' where " & UpdateKey & "='" & kc1.Fields(Col) & "'")
End Sub

Public Sub TEXTCOLOR1_End() '第一结束方式
txtRecive.SelStart = newstart
txtRecive.SelLength = Len(txtRecive.Text) - newstart
txtRecive.SelColor = &HFFFF&
End Sub
Public Sub TEXTCOLOR2_End() '第二结束方式
txtRecive.SelStart = newstart
txtRecive.SelLength = Len(txtRecive.Text) - newstart
txtRecive.SelColor = &HFFFF80   'vbWhite
End Sub
Public Sub TEXTCOLOR3_End() '第三结束方式
txtRecive.SelStart = newstart
txtRecive.SelLength = Len(txtRecive.Text) - newstart
txtRecive.SelColor = &HC0C0FF
End Sub
Public Sub TEXTCOLOR4_End() '第三结束方式
txtRecive.SelStart = newstart
txtRecive.SelLength = Len(txtRecive.Text) - newstart
txtRecive.SelColor = vbWhite
End Sub

Public Sub TEXTCOLOR_Start()
newstart = Len(txtRecive.Text)
txtRecive.SelStart = newstart '定义起点,避免覆盖文本
End Sub