b课本调整.frm

用vb实现学校自动排课

    If rst1.RecordCount > 0 And M_Flag = True Then   '如果班级信息存在，且排课条件设置正确
        Do While Not rst1.EOF
            strClass = rst1.Fields("班级名称")
            Call GenerateCT_ByClass(strClass)  '按班级生成课程表
            rst1.MoveNext
        Loop
        MsgBox ("已经生成了真实课表！")
    End If
End Sub
Private Sub GenerateCT_ByClass(strClass As String)
'按班级生成课程表
    Dim rst1 As ADODB.Recordset
    Dim strCourse As String    '定义课程名称变量
    '@1初始化班级课表 M_courseTable
    For index = 1 To M_segmentNum
        For index2 = 1 To 7
            M_courseTable(index, index2) = ""
        Next index2
    Next index
    '@2得到班级的课程集
    SQL = " select 课程名称 from 班级课程信息表 where 班级名称='" & strClass & "'order by 课程名称"
    Set rst1 = SelectSQL(SQL, msg)
    '@3遍历班级的每一门课程,并进行课程安排
    If rst1.RecordCount > 0 And M_Flag = True Then
        Do While Not rst1.EOF
            strCourse = rst1.Fields("课程名称")
            M_course = strCourse                                  '赋值给模块变量
            M_class = strClass                                    '赋值给模块变量
            Call GenerateCT_ByClassAndCourse(strClass, strCourse) '给每个班的每一门课进行课程安排
            rst1.MoveNext
        Loop
    End If
    '@4将M_courseTable矩阵写入到排课信息表
    SQL = "SELECT 节号,星期一,星期二,星期三,星期四,星期五,星期六,星期日"
    SQL = SQL & " FROM 排课信息表 where 班级名称='" & strClass & "' ORDER BY 节号"
    Set rst1 = SelectSQL(SQL, msg)
    If M_Flag = True Then                 '如果排课条件设置正确，将M_courseTable写入到排课信息表
        For index = 1 To M_segmentNum
            For index2 = 1 To 7
                rst1.Fields(index2) = M_courseTable(index, index2)
            Next index2
            rst1.Update
            rst1.MoveNext
        Next index
    End If
End Sub
Private Sub GenerateCT_ByClassAndCourse(strClass As String, strCourse As String)
'给每个班的每一门课进行课程安排
    Dim rst1 As ADODB.Recordset
    Dim segmentNum As Integer  '定义每周的授课节数变量
    Dim courseRang As String   '定义课程分布变量
    Dim splitCourse As Integer '定义需要排课的次数，两节课需要累排
    Dim flag As Boolean        '如果每周有偶数节课flag为True,奇数节课为false
    Dim dayindex1 As Integer   '课程分布开始日期的序列号
    Dim dayindex2 As Integer   '课程分布结束日期的序列号
    Dim index1 As Integer
    '@1得到课程信息
    SQL = " select 班级名称,课程名称,每周节数,课程分布 from 班级课程信息表 "
    SQL = SQL & "where 班级名称='" & strClass & "' and 课程名称='" & strCourse & "'"
    Set rst1 = SelectSQL(SQL, msg)
    segmentNum = rst1.Fields("每周节数")
    courseRang = rst1.Fields("课程分布")
    '@2得到需要进行排课的次数
    If segmentNum = 0 Then Exit Sub        '如果该课程的授课次数为0，退出函数
    splitCourse = Int(segmentNum / 2)
    If splitCourse * 2 = segmentNum Then    '如果该课程每周的授课节数是偶数
        flag = True
    Else                                    '如果该课程每周的授课节数是奇数
        flag = False
        splitCourse = splitCourse + 1
    End If
    '@3得到课程分布的序列号
    dayindex1 = GetDayIndex(Left(courseRang, 3))    '得到课程分布开始日期的序列号
    dayindex2 = GetDayIndex(Right(courseRang, 3))   '得到课程分布结束日期的序列号
    '@4对课程进行排课，遍历所有的排课次数
    For index1 = 1 To splitCourse
        If flag = True Then                 '如果该课程每周的授课节数是偶数
            Call setCourseToM_courseTable(strCourse, dayindex1, dayindex2, True)
        Else                                '如果该课程每周的授课节数是奇数
            If index1 <> splitCourse Then    '如果不是最后一组
                Call setCourseToM_courseTable(strCourse, dayindex1, dayindex2, True)
            Else                            '如果是最后一组
               Call setCourseToM_courseTable(strCourse, dayindex1, dayindex2, False)
            End If
        End If
        If M_Flag = False Then Exit For     '排课条件设置有问题，退出排课
    Next index1
End Sub
Private Sub setCourseToM_courseTable(strCourse As String, dayindex1 As Integer, dayindex2 As Integer, flag As Boolean)
'将课程写入到M_courseTable课表矩阵
    Dim temp As Integer
    Dim randIndex As Integer
    M_colIndex = 0
    M_rowIndex = 0
    '@1随机选择一日
    Randomize       '随机数种子
    randIndex = Int(Rnd() * (dayindex2 - dayindex1)) + dayindex1
    '@2得到插入的位置
    Call GetPosition(randIndex, dayindex2, flag)        '在randIndex至dayindex2之间进行遍历
    If M_rowIndex = 0 Then                              '如果没有找到，就从dayindex1至randIndex之间进行遍历
         Call GetPosition(dayindex1, randIndex, flag)
    End If
    '@3设置M_courseTable
    If M_rowIndex = 0 Then                           '如果安排不下，报告排课条件错误
        MsgBox ("排课条件设置有问题！" & strCourse & "无法排下！")
        M_Flag = False
    Else                                            '如果可以安排，设置M_courseTable的值
        If flag = True Then
            M_courseTable(M_rowIndex, M_colIndex) = strCourse
            M_courseTable(M_rowIndex + 1, M_colIndex) = strCourse
        Else
            M_courseTable(M_rowIndex, M_colIndex) = strCourse
        End If
        M_Flag = True
    End If
End Sub
Private Sub GetPosition(startIndex As Integer, endIndex As Integer, flag As Boolean)
'得到课程能够插入的位置
    Dim temp As Integer
    Dim randSegment As Integer
    '@1随机选择某一节号
    Randomize       '随机数种子
    randSegment = Int(Rnd() * (M_segmentNum - 1)) + 1
    '@2遍历节，在startIndex至endIndex之间开始遍历
    For temp = startIndex To endIndex
        '在randSegment至M_segmentNum之间开始遍历
        For index = randSegment To M_segmentNum
            If flag = True Then           '如果需要累排，检查是否能够累排两节课
                If index + 1 <= M_segmentNum Then
                    If M_courseTable(index, temp) = "" And M_courseTable(index + 1, temp) = "" Then
                        M_rowIndex = index
                        M_colIndex = temp
                    End If
                End If
            Else                           '如果不需要累排，检查是否能够排一节课
                 If M_courseTable(index, temp) = "" Then
                    M_rowIndex = index
                    M_colIndex = temp
                End If
            End If
            If M_rowIndex > 0 And TestAvialable(M_rowIndex, M_colIndex, flag) Then Exit Sub    '如果找到了，就退出函数
        Next index
        '如果没有找到插入位置，在1到randSegment之内开始遍历
        For index = 1 To randSegment
            If flag = True Then           '如果需要累排，检查是否能够累排两节课
                If index + 1 <= M_segmentNum Then
                    If M_courseTable(index, temp) = "" And M_courseTable(index + 1, temp) = "" Then
                        M_rowIndex = index
                        M_colIndex = temp
                    End If
                End If
            Else                          '如果不需要累排，检查是否能够排一节课
                 If M_courseTable(index, temp) = "" Then
                    M_rowIndex = index
                    M_colIndex = temp
                End If
            End If
            If M_rowIndex > 0 And TestAvialable(M_rowIndex, M_colIndex, flag) Then Exit Sub     '如果找到了，就退出函数
        Next index
    Next temp
End Sub
Private Function GetDayName(index As Integer) As String
'根据日期序号得到日期名称
    Select Case index
        Case 1
            GetDayName = "星期一"
        Case 2
            GetDayName = "星期二"
        Case 3
            GetDayName = "星期三"
        Case 4
            GetDayName = "星期四"
        Case 5
            GetDayName = "星期五"
        Case 6
            GetDayName = "星期六"
        Case 7
            GetDayName = "星期日"
    End Select
End Function
Private Function GetDayIndex(dayName As String) As String
'根据日期名称得到日期序号
    Select Case dayName
        Case "星期一"
            GetDayIndex = 1
        Case "星期二"
            GetDayIndex = 2
        Case "星期三"
            GetDayIndex = 3
        Case "星期四"
            GetDayIndex = 4
        Case "星期五"
            GetDayIndex = 5
        Case "星期六"
            GetDayIndex = 6
        Case "星期日"
            GetDayIndex = 7
    End Select
End Function
Private Function TestAvialable(rowIndex As Integer, colIndex As Integer, flag As Boolean) As Boolean
'检测教师资源是否冲突
    Dim rst1 As ADODB.Recordset
    Dim rst2 As ADODB.Recordset
    Dim teacher As String
    Dim dayName As String
    Dim count As Integer
    dayName = GetDayName(colIndex)
    count = 1
    TestAvialable = True
    '@1得到当前课程的任课教师
    SQL = "select 任课教师 from 班级课程信息表 where 班级名称='" & M_class & "' and 课程名称='" & M_course & "'"
    Set rst1 = SelectSQL(SQL, msg)
    teacher = rst1.Fields("任课教师")
    '@2得到教师所有的授课班级
    SQL = "select 班级名称 from 班级课程信息表 where  任课教师='" & teacher & "'"
    Set rst1 = SelectSQL(SQL, msg)
    '@3遍历每一个班的课表，看看教师的授课时间是否冲突
    Do While Not rst1.EOF
        SQL = "SELECT 节号,星期一,星期二,星期三,星期四,星期五,星期六,星期日"
        SQL = SQL & " FROM 排课信息表 where 班级名称='" & rst1.Fields("班级名称") & "' ORDER BY 节号"
        Set rst2 = SelectSQL(SQL, msg)
        Do While Not rst2.EOF
            If count = rowIndex Then
                If rst2.Fields(dayName) = M_course Then
                    TestAvialable = False
                    Exit Function
                Else
                    If flag = True Then         '如果课程需要累排，检查下一节课是否冲突
                        rst2.MoveNext
                        If rst2.Fields(dayName) = M_course Then
                            TestAvialable = False
                            Exit Function
                        End If
                    End If
                End If
                Exit Do                         '退出循环
            End If
            count = count + 1
            rst2.MoveNext
        Loop
        rst1.MoveNext
    Loop
End Function
Private Sub CmdExit_Click()
'退出操作
    排课系统.Enabled = True
    Unload Me
End Sub
Private Sub Form_Unload(Cancel As Integer)
'退出操作
    排课系统.Enabled = True
    rs.Close
    Unload Me
End Sub