frmin.frm

VB编写的中小学监考老师排表软件

Next i

'If List2.ListCount = 0 Then
'MsgBox "考试课程不能为空"
'Exit Sub
'End If

HFGd1.AddItem "" + vbTab + "" + vbTab + "" + vbTab + ""
ksbjS = ksbjS + 1
'MsgBox ksbjs
'写数组
'ReDim bjarr(ksbjS)

'For r = 1 To ksbjS
     r = ksbjS
     
    With HFGd1
        .Row = r
        .Col = 2
        newbjitem.njm = .Text
        .Col = 3
        newbjitem.bjh = .Text
        newbjitem.kskc.num = List2.ListCount
        For i = 1 To newbjitem.kskc.num
        newbjitem.kskc.list(i) = List2.list(i - 1)
        Next
    End With
    
    For i = 0 To Class - 1
    For j = 0 To Day - 1
    newbjitem.ksbiao(i, j) = "x"
    newbjitem.jsbiao1(i, j) = "x"
    newbjitem.jsbiao2(i, j) = "x"
    newbjitem.ksbiaoID(i, j) = "x"
    Next
    Next
    
    bjarr(r) = newbjitem
'Next

Cmbnjm.Move 100, 100
Cmbbjh.Move 100, 100

End Sub

Private Sub Image11_Click()
'最后一栏保持不删
If HFGd1.Row = ksbjS + 1 Then
MsgBox "至少应保留一个班级输入栏！"
Exit Sub
End If

Dim ans, nowrow As Integer
Dim strnj, strbh As String
nowrow = HFGd1.Row
HFGd1.Col = 2
strnj = Trim(HFGd1.Text)
HFGd1.Col = 3
strbh = Trim(HFGd1.Text)
ans = MsgBox("确是要删去“" + strnj + strbh + "”班吗？", vbYesNo, "输入考试班级")

If ans = 6 Then

HFGd1.RemoveItem nowrow
'后部班级数组前移
For i = nowrow To ksbjS - 1
bjarr(i) = bjarr(i + 1)
Next i
ksbjS = ksbjS - 1

'删去教师数组中有本班的监考
For i = 1 To jkjsS
For k = 0 To Class - 1
For l = 0 To Day - 1
If InStr(jsarr(i).jkbiao1(k, l), strnj + strbh) <> 0 Then
jsarr(i).jkbiao1(k, l) = "x"
jsarr(i).jkbiao2(k, l) = "x"
End If
Next l
Next k
Next i

End If
End Sub


Private Sub Image2_Click()
Dim i As Integer
'HFGd2.Row < jkjss And
If (HFGd2.Row > 0) Then
List4.Clear

For i = 0 To List3.ListCount - 1
If List3.Selected(i) = True Then
List4.AddItem List3.list(i)
End If
Next i

For i = 1 To List4.ListCount
jsarr(HFGd2.Row).rjbj.list(i) = List4.list(i - 1)
Next i

jsarr(HFGd2.Row).rjbj.num = List3.SelCount

Else

MsgBox "请先指定当前教师！"
End If

End Sub

Public Sub Image3_Click()
Dim r, i As Integer

HFGd2.Row = jkjsS + 1
HFGd2.Col = 2

If HFGd2.Text = "" Then
MsgBox "教师名不能为空"
jsmIsNull = True
Exit Sub
Else
jsmIsNull = False
End If


HFGd2.AddItem "" + vbTab + "" + vbTab + "" + vbTab + ""
jkjsS = jkjsS + 1
'MsgBox ksbjs
'写数组
'ReDim jsarr(jkjsS + 3)

'For r = 1 To jkjsS
r = jkjsS
With HFGd2
    .Row = r
    .Col = 2
    newjsitem.jsm = Trim(.Text)
    .Col = 3
    'If Trim(.Text) = "" Then
    '.Text = "其他"
    newjsitem.rkm = .Text
    'End If
End With

    'List4.Clear
    'List4.AddItem "不定"
 
    newjsitem.rjbj.num = List4.ListCount
    For bj = 1 To newjsitem.rjbj.num
    newjsitem.rjbj.list(bj) = Trim(List4.list(bj - 1))
    Next bj

For i = 0 To Class - 1
For j = 0 To Day - 1
newjsitem.jkbiao1(i, j) = "x"
newjsitem.jkbiao2(i, j) = "x"
Next j
Next i

jsarr(r) = newjsitem

'Next

HFGd2.Col = 1
End Sub

Private Sub Image5_Click()
Dim strjsL As String
Dim strM(150) As String * 3
Dim m, i, startpos, endPos As Integer
strjsL = Clipboard.GetText
If Len(strjsL) < 9 Then
MsgBox "目前没有复制的教师名数据！请打开有关已包含了教师名的Excel表文件，并在其上复制一系列连续的教师姓名（以行的形式或以列的形式均可）。"
Exit Sub
End If
If Len(strjsL) > 250 Then
MsgBox "复制串太长，请重新复制！"
Exit Sub
End If

ans = MsgBox("已复制的内容如下，要将其粘帖到教师表内吗？" + Chr(13) + Chr(10) + strjsL, vbYesNo)
If ans = vbNo Then Exit Sub

m = 0
startpos = 1
'endpos = 1
For i = 1 To Len(strjsL)
If Mid(strjsL, i, 1) = Chr(9) Or Mid(strjsL, i, 2) = Chr(13) + Chr(10) Then
m = m + 1
endPos = i - 1
strM(m) = Mid(strjsL, startpos, endPos)
    If Mid(strjsL, i, 1) = Chr(9) Then
    startpos = i + 1
    End If
    If Mid(strjsL, i, 2) = Chr(13) + Chr(10) Then
    startpos = i + 2
    End If
End If
Next i
'按项添加到教师输入表中
HFGd2.Row = HFGd2.Rows - 1
HFGd2.Col = 2
textjsm.Left = HFGd2.Left + 200 + 450
textjsm.Top = HFGd2.Top + HFGd2.RowPos(HFGd2.Row) + 50 '(HFGd1.Row + 1) * 300
textjsm.Visible = True

For i = 1 To m
If Len(strM(i)) < 7 Then

textjsm.Text = strM(i)
Call textjsm_KeyPress(13)

End If
Next i
textjsm.Visible = False


End Sub

Private Sub Image6_Click()
'最后一栏保持不删
If HFGd2.Row = jkjsS + 1 Then
MsgBox "至少应保留一教师输入栏！"
Exit Sub
End If

Dim ans, nowrow As Integer
Dim strjs, strkc As String
nowrow = HFGd2.Row
HFGd2.Col = 2
strjs = Trim(HFGd2.Text)
'HFGd1.Col = 3
'strkc = HFGd2.Text
ans = MsgBox("确是要删去“" + strjs + "”教师吗？", vbYesNo, "输入考试班级")

If ans = 6 Then

HFGd2.RemoveItem nowrow

For i = nowrow To jkjsS - 1
jsarr(i) = jsarr(i + 1)
Next i
jkjsS = jkjsS - 1

'删去班级数组中有本教师监考的节
For b = 1 To ksbjS
For k = 0 To Class - 1
For l = 0 To Day - 1
If InStr(bjarr(b).jsbiao1(k, l), strjs) <> 0 Then
bjarr(b).jsbiao1(k, l) = "x"
End If

If InStr(bjarr(b).jsbiao2(k, l), strjs) <> 0 Then
bjarr(b).jsbiao2(k, l) = "x"
End If
Next l
Next k
Next b

End If


End Sub

Private Sub Image7_Click()
'确认教师数组数据
Cmbkcm.Visible = False
textjsm.Visible = False

Dim i, j As Integer
Dim strjs, strkc As String
For i = 1 To HFGd2.Rows - 2
HFGd2.Row = i
HFGd2.Col = 2
'strjs = Trim(HFGd2.Text)
If Trim(HFGd2.Text) = "" Or Len(HFGd2.Text) > 4 Then

HFGd2.Col = 0
HFGd2.ColSel = 3
MsgBox "第" + Str(i) + "行教师名不能为空"
'jsOk = False
Exit Sub
End If

Next i

'check for repeated js
For i = 1 To HFGd2.Rows - 2
HFGd2.Row = i
HFGd2.Col = 2
strjs = Trim(HFGd2.Text)

For j = i + 1 To HFGd2.Rows - 1
HFGd2.Row = j
HFGd2.Col = 2
If Trim(HFGd2.Text) = strjs Then
HFGd2.Col = 0
HFGd2.ColSel = 3
MsgBox "不能有同名教师重复" '+ strjs + Str(HFGd2.Row)
'jsOk = False
Exit Sub
End If
Next j
Next i

jkjsS = HFGd2.Rows - 1

For i = 1 To jkjsS '=HFGd2.Rows - 1
'写教师数组
HFGd2.Row = i
HFGd2.Col = 2
strjs = Trim(HFGd2.Text)

HFGd2.Row = i
HFGd2.Col = 3
strkc = Trim(HFGd2.Text)
If strkc = "" Then strkc = "其他"

With jsarr(i)
.jsm = strjs
.rkm = strkc
End With
Next i

'jsOk = True
End Sub

Private Sub Image8_Click()
If HFGd1.Row = 1 Or HFGd1.Row = ksbjS + 1 Then
Exit Sub
End If

Dim nowrow As Integer
Dim strnowrow, strnj, strbh As String
HFGd1.Col = 2
strnj = HFGd1.Text
HFGd1.Col = 3
strbh = HFGd1.Text

strnowrow = "" + vbTab + "" + vbTab + strnj + vbTab + strbh
nowrow = HFGd1.Row
' 数祖内交换
newbjitem = bjarr(nowrow - 1)
bjarr(nowrow - 1) = bjarr(nowrow)
bjarr(nowrow) = newbjitem
'表内交换
HFGd1.RemoveItem nowrow
HFGd1.AddItem strnowrow, nowrow - 1
HFGd1.Row = nowrow - 1
HFGd1.Col = 0
HFGd1.ColSel = 3

'List2.Clear
'For i = 1 To bjarr(nowrow).kskc.num
'List2.AddItem bjarr(nowrow).kskc.list(i)
'Next i

End Sub


Private Sub Image9_Click()
If HFGd1.Row = ksbjS Or HFGd1.Row = ksbjS + 1 Then
Exit Sub
End If

Dim nowrow As Integer
Dim strnowrow, strnj, strbh As String
HFGd1.Col = 2
strnj = HFGd1.Text
HFGd1.Col = 3
strbh = HFGd1.Text

strnowrow = "" + vbTab + "" + vbTab + strnj + vbTab + strbh
nowrow = HFGd1.Row
' 数祖内交换
newbjitem = bjarr(nowrow + 1)
bjarr(nowrow + 1) = bjarr(nowrow)
bjarr(nowrow) = newbjitem
'表内交换
HFGd1.RemoveItem nowrow
HFGd1.AddItem strnowrow, nowrow + 1
HFGd1.Row = nowrow + 1
HFGd1.Col = 0
HFGd1.ColSel = 3

'List2.Clear
'For i = 1 To bjarr(nowrow).kskc.num
'List2.AddItem bjarr(nowrow).kskc.list(i)
'Next i
End Sub


Private Sub mnuback_Click()
Unload Me
'Load MDIForm1
'MDIForm1.Show '.Visible = True

End Sub

Private Sub textjsm_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then 'And HFGd2.Row < HFGd2.Rows - 1 Then
 Dim r, i, bj As Integer
 Dim strjsM As String
 strjsM = Trim(textjsm.Text)
If strjsM = "" Then
MsgBox "教师名不能为空"
jsmIsNull = True
Exit Sub
Else
jsmIsNull = False
End If

Cmbkcm.Visible = False
HFGd2.Text = strjsM ' textjsm.Text

'写数组
r = jkjsS + 1
With HFGd2
    '.Row = r
    '.Col = 2
    newjsitem.jsm = strjsM ' Trim(.Text)
    
    .Col = 3
    If Trim(.Text) = "" Then
    .Text = "其他"
    End If
    newjsitem.rkm = .Text
    
    'If List4.ListCount = 0 Then
    List4.Clear
    List4.AddItem "不定"
    'End If
    newjsitem.rjbj.num = List4.ListCount
    For bj = 1 To newjsitem.rjbj.num
    newjsitem.rjbj.list(bj) = Trim(List4.list(bj - 1))
    Next bj
End With

For i = 0 To Class - 1
For j = 0 To Day - 1
newjsitem.jkbiao1(i, j) = "x"
newjsitem.jkbiao2(i, j) = "x"
Next j
Next i

jsarr(r) = newjsitem

HFGd2.AddItem "" + vbTab + "" + vbTab + "" + vbTab + ""
jkjsS = r 'jkjss + 1
HFGd2.Row = HFGd2.Row + 1
HFGd2.Col = 2
    
    With textjsm
    .Visible = True
    .Text = ""
    .Left = HFGd2.Left + 200 + 450
    .Top = HFGd2.Top + HFGd2.RowPos(HFGd2.Row) + 50 '(HFGd1.Row + 1) * 300
    End With
  'MsgBox jsarr(jkjss).jsm
  
'向上移行处理
If HFGd2.Rows > 14 Then
HFGd2.TopRow = HFGd2.TopRow + 1
textjsm.Top = HFGd2.Top + HFGd2.Height - 500
End If

End If
End Sub