frmverify.frm

这是我们公司的题库管理系统

            sSQL = "select * from ITEM where VERIFY_STATUS = '待审'" _
                    & " and CATEGORY_ID in " _
                    & " (select CATEGORY_ID from CATEGORIES where SUPER_CATEGORY_ID in " _
                    & " (select CATEGORY_ID from CATEGORIES where SUPER_CATEGORY_ID in " _
                    & " (select CATEGORY_ID from CATEGORIES where SUPER_CATEGORY_ID = " & categoryId & ")))"
        ElseIf categoryId = 3 Then
            sSQL = "select * from ITEM where VERIFY_STATUS = '待审'" _
                    & " and CATEGORY_ID in " _
                    & " (select CATEGORY_ID from CATEGORIES where SUPER_CATEGORY_ID = " & categoryId & ")"
        End If
    End If
    rsItem.Open sSQL, cnn
    'It is added here
    DoEvents
    '///////////////
    resetSpace
    showItem
    
    LoadResStrings Me
    Form_Resize
    SetButtons True
    
    Screen.MousePointer = Default
End Sub

Private Sub Form_Terminate()
On Error Resume Next
    If Not rs Is Nothing Then
        rs.Close
        Set rs = Nothing
    End If
    If Not cnn Is Nothing Then
        cnn.Close
        Set cnn = Nothing
    End If
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    
    picItemContent.Width = Me.ScaleWidth - 4500
    myToolbar.Top = Me.ScaleHeight - 750
    
    picItemContent.Height = Me.ScaleHeight - 1300
    picItemArgs.Height = Me.ScaleHeight - 1300
    
    lQuestion.Top = 500
    rtfTextQuestion.Move 100, 700, picItemContent.ScaleWidth - 200, (picItemContent.ScaleHeight - 500) / 2 - 300
    rtfTextQuestion.RightMargin = rtfTextQuestion.Width - 400
    lAnswer.Top = 500 + (picItemContent.ScaleHeight - 500) / 2
    rtfTextAnswer.Move 100, 700 + (picItemContent.ScaleHeight - 500) / 2, picItemContent.ScaleWidth - 200, (picItemContent.ScaleHeight - 500) / 2 - 300
    rtfTextAnswer.RightMargin = rtfTextAnswer.Width - 400
End Sub

Private Sub myToolbar_ButtonClick(ByVal ButtonIndex As Integer, ByVal ButtonKey As String)
    'On Error Resume Next
    Select Case ButtonKey
        Case "verify"
            If categoryId = 1 Then
                Response = MsgBox("本试题的试题编码为： " _
                    & idToNum(categoryId) & "-" _
                    & idToNum(fieldId) & "-" _
                    & idToNum(courseId) & "-" _
                    & idToNum(pointId) & "-" _
                    & rsItem!KEY_ID & "-" _
                    & rsItem!TYPE_ID & "-" _
                    & rsItem!LEVEL_ID & "-" _
                    & rsItem!TARGET_ID & "-" _
                    & rsItem!MAXMARK & "-" _
                    & rsItem!DURATION & "-" _
                    & rsItem!SERIAL _
                    & Chr(13) + Chr(10) + Chr(13) + Chr(10) _
                    & "审核通过的试题将进入试题库备用，确定审核通过本试题？", vbQuestion + vbYesNo)
            ElseIf categoryId = 2 Then
                Response = MsgBox("本试题的试题编码为： " _
                    & idToNum(categoryId) & "-" _
                    & idToNum(fieldId) & "-" _
                    & idToNum(courseId) & "-" _
                    & idToNum(pointId) & "-" _
                    & rsItem!TYPE_ID & "-" _
                    & rsItem!LEVEL_ID & "-" _
                    & rsItem!TARGET_ID & "-" _
                    & rsItem!MAXMARK & "-" _
                    & rsItem!DURATION & "-" _
                    & rsItem!SERIAL _
                    & Chr(13) + Chr(10) + Chr(13) + Chr(10) _
                    & "审核通过的试题将进入试题库备用，确定审核通过本试题？", vbQuestion + vbYesNo)
            ElseIf categoryId = 3 Then
                Response = MsgBox("本试题的试题编码为： " _
                    & idToNum(categoryId) & "-" _
                    & idToNum(fieldId) & "-" _
                    & rsItem!LEVEL_ID & "-" _
                    & rsItem!MAXMARK & "-" _
                    & rsItem!DURATION & "-" _
                    & rsItem!SERIAL _
                    & Chr(13) + Chr(10) + Chr(13) + Chr(10) _
                    & "审核通过的试题将进入试题库备用，确定审核通过本试题？", vbQuestion + vbYesNo)
            End If
            If Response = vbNo Then
                Cancel = True
            Else
                verifyItem
            End If
        Case "edit"
            editItem
            'frmMain.sbStatusBar.Panels(1).Text = frmAddItemC.Caption + ": 编辑试题"
        Case "save"
            updateItem
        Case "cancel"
            cancelItem
        Case "delete"
            deleteItem
        Case "previous"
            previousItem
        Case "next"
            nextItem
        Case "close"
            Unload Me
    End Select
End Sub

Private Sub verifyItem()
    On Error GoTo verifyErr
    With rsItem
        !VERIFY_STATUS = "已审"
        .Update
        .Requery
        showItem
    End With
    DoEvents
    Exit Sub
verifyErr:
    resetSpace
    MsgBox "已经审核完成所有待审试题！", vbInformation + vbOKOnly
    Unload Me
End Sub

Private Sub editItem()
  On Error GoTo EditErr

  'lblStatus.Caption = "Editing the information of the customer"
  mvBookMark = rsItem.Bookmark
  SetButtons False
  lSerial.Visible = True
  txtSerial.Visible = True
  oldItemSerial = txtSerial.Text
  Exit Sub

EditErr:
  MsgBox Err.Description
End Sub

Private Sub cancelItem()
  On Error Resume Next

  mbAddNewFlag = False
  rsItem.CancelUpdate
  If mvBookMark > 0 Then
    rsItem.Bookmark = mvBookMark
  Else
    rsItem.MoveFirst
  End If
  showItem
  SetButtons True

End Sub

Private Sub deleteItem()
  Response = MsgBox("确定要删除此题吗?", vbYesNo, Me.Caption)
  If Response = vbNo Then
     Cancel = True
  Else
    On Error GoTo DeleteErr
    With rsItem
      .Delete
      .MoveNext
      If .EOF Then .MoveLast
    End With
    showItem
    Exit Sub
DeleteErr:
    'MsgBox Err.Description
    resetSpace
  End If
End Sub

Private Sub checkIfSerialExistAlready()
    serialExistAlready = False
    
    ' check
    Set rsSerial = New Recordset
    rs.CursorLocation = adUseClient
    If categoryId = 1 Or categoryId = 2 Then
        sSQL = "select * from ITEM where CATEGORY_ID = " & pointId _
            & " and TYPE_ID = '" & Format(CombList(0).ItemData(CombList(0).ListIndex), "00") & "'" _
            & " and SERIAL not in ('" & oldItemSerial & "')" _
            & " Order by SERIAL"
    ElseIf categoryId = 3 Then
        sSQL = "select * from ITEM where CATEGORY_ID = " & fieldId _
            & " and SERIAL not in ('" & oldItemSerial & "')" _
            & " Order by SERIAL"
    End If
    rsSerial.Open sSQL, cnn, adOpenStatic, adLockReadOnly
    If Not rsSerial.EOF Then
        While Not rsSerial.EOF
            If rsSerial!SERIAL = txtSerial.Text Then
                serialExistAlready = True
                ' return suggested serial number
                rsSerial.MoveLast
                suggestedItemSerial = Format(rsSerial!SERIAL + 1, "0000")
            End If
            rsSerial.MoveNext
        Wend
    End If

    rsSerial.Close
End Sub

Private Sub getItemSerial()
    Set rsSerial = New Recordset
    rs.CursorLocation = adUseClient
    If categoryId = 1 Or categoryId = 2 Then
        sSQL = "select * from ITEM where CATEGORY_ID = " & pointId _
            & " and TYPE_ID = '" & Format(CombList(0).ItemData(CombList(0).ListIndex), "00") & "'" _
            & " Order by SERIAL"
    ElseIf categoryId = 3 Then
        sSQL = "select * from ITEM where CATEGORY_ID = " & fieldId _
            & " and TYPE_ID = '" & Format(CombList(0).ItemData(CombList(0).ListIndex), "00") & "'" _
            & " Order by SERIAL"
    End If
    rsSerial.Open sSQL, cnn, adOpenStatic, adLockReadOnly
    If rsSerial.EOF Then
        itemSerial = "0001"
    Else
        rsSerial.MoveLast
        itemSerial = Format(rsSerial!SERIAL + 1, "0000")
    End If
    rsSerial.Close
End Sub

Private Sub updateItem()
'    On Error GoTo UpdateErr
    
    If rsItem!SERIAL <> "" Then
        If Len(txtSerial.Text) = 4 Then
            checkIfSerialExistAlready
            If serialExistAlready Then
                MsgBox "序列号已存在，请重新输入序列号！建议序列号为：" & suggestedItemSerial, vbInformation + vbOKOnly
                Exit Sub
            Else
                itemSerial = txtSerial.Text
            End If
        Else
            MsgBox "请输入4位试题序列号！", vbInformation + vbOKOnly
            Exit Sub
        End If
    Else
        getItemSerial
    End If
    
    With rsItem
        If categoryId = 1 Or categoryId = 2 Then
            !CATEGORY_ID = pointId
            !TYPE_ID = Format(CombList(0).ItemData(CombList(0).ListIndex), "00")
            !LEVEL_ID = Format(CombList(1).ItemData(CombList(1).ListIndex), "00")
            !TARGET_ID = Format(CombList(2).ItemData(CombList(2).ListIndex), "00")
        Else
            !CATEGORY_ID = fieldId
            !LEVEL_ID = Format(CombList(1).ItemData(CombList(1).ListIndex), "00")
        End If
        !KEY_ID = "00"
        !SERIAL = itemSerial
        !QUES_CONTENT = rtfTextQuestion.Text
        !ANSWER = rtfTextAnswer.Text
        !MAXMARK = Format(txtMark.Text, "00")
        !DURATION = Format(txtDuration.Text, "00")
        !VERIFY_STATUS = "待审"
        !USAGE_STATUS = "未用"
        !INPUT_DATE = Date
        !INPUT_STAFF_ID = userName  'ID与系统管理模块相结合
        If checkValidity.Value = 1 Then
            !VALIDITY = True
        Else
            !VALIDITY = False
        End If
        .Update
    End With

    If searchItemId = -1 Then
        If mbAddNewFlag Then
          rsItem.MoveLast              'move to new record
        End If
        
        mbAddNewFlag = False
        SetButtons True
        showItem
    Else
        searchItemId = -1
        Unload Me
    End If
  Exit Sub
UpdateErr:
  MsgBox Err.Description
End Sub

Private Sub nextItem()
  On Error GoTo GoNextError

  If Not rsItem.EOF Then rsItem.MoveNext
  If rsItem.EOF And rsItem.RecordCount > 0 Then
    Beep
     'reach the last record
    rsItem.MoveLast
  End If
  'show current record
 ' mbDataChanged = False
  showItem

  Exit Sub
GoNextError:
  MsgBox Err.Description
End Sub

Private Sub previousItem()
  On Error GoTo GoPrevError

  If Not rsItem.BOF Then rsItem.MovePrevious
  If rsItem.BOF And rsItem.RecordCount > 0 Then
    Beep
    'reach the last record
    rsItem.MoveFirst
  End If
  'show current record
  'mbDataChanged = False
  showItem

  Exit Sub

GoPrevError:
  MsgBox Err.Description
End Sub


Private Sub tbToolBar_ButtonClick(ByVal Button As MSComctlLib.Button)
    On Error Resume Next
    If focusOnQuestion Then
        Select Case Button.Key
            Case "剪切"
                Clipboard.SetText rtfTextQuestion.SelRTF
                rtfTextQuestion.SelText = vbNullString
            Case "复制"
                Clipboard.SetText rtfTextQuestion.SelRTF
            Case "粘贴"
                rtfTextQuestion.SelRTF = Clipboard.GetText
            Case "粗体"
                rtfTextQuestion.SelBold = Not rtfTextQuestion.SelBold
                Button.Value = IIf(rtfTextQuestion.SelBold, tbrPressed, tbrUnpressed)
            Case "斜体"
                rtfTextQuestion.SelItalic = Not rtfTextQuestion.SelItalic
                Button.Value = IIf(rtfTextQuestion.SelItalic, tbrPressed, tbrUnpressed)
            Case "下划线"
                rtfTextQuestion.SelUnderline = Not rtfTextQuestion.SelUnderline
                Button.Value = IIf(rtfTextQuestion.SelUnderline, tbrPressed, tbrUnpressed)
            Case "左对齐"
                rtfTextQuestion.SelAlignment = rtfLeft
            Case "置中"
                rtfTextQuestion.SelAlignment = rtfCenter
            Case "右对齐"
                rtfTextQuestion.SelAlignment = rtfRight
        End Select
    ElseIf focusOnAnswer Then
        Select Case Button.Key
            Case "剪切"
                Clipboard.SetText rtfTextAnswer.SelRTF
                rtfTextAnswer.SelText = vbNullString
            Case "复制"
                Clipboard.SetText rtfTextAnswer.SelRTF
            Case "粘贴"
                rtfTextAnswer.SelRTF = Clipboard.GetText
            Case "粗体"
                rtfTextAnswer.SelBold = Not rtfTextAnswer.SelBold
                Button.Value = IIf(rtfTextAnswer.SelBold, tbrPressed, tbrUnpressed)
            Case "斜体"
                rtfTextAnswer.SelItalic = Not rtfTextAnswer.SelItalic
                Button.Value = IIf(rtfTextAnswer.SelItalic, tbrPressed, tbrUnpressed)
            Case "下划线"
                rtfTextAnswer.SelUnderline = Not rtfTextAnswer.SelUnderline
                Button.Value = IIf(rtfTextAnswer.SelUnderline, tbrPressed, tbrUnpressed)
            Case "左对齐"
                rtfTextAnswer.SelAlignment = rtfLeft
            Case "置中"
                rtfTextAnswer.SelAlignment = rtfCenter
            Case "右对齐"
                rtfTextAnswer.SelAlignment = rtfRight
        End Select
    End If
    
End Sub

Private Sub SetButtons(bVal As Boolean)
    myToolbar.ButtonVisible(1) = bVal
    myToolbar.ButtonVisible(2) = bVal
    myToolbar.ButtonVisible(4) = bVal
    myToolbar.ButtonVisible(5) = bVal
    myToolbar.ButtonVisible(6) = bVal
    myToolbar.ButtonVisible(7) = bVal
    myToolbar.ButtonVisible(8) = Not bVal
    myToolbar.ButtonVisible(9) = Not bVal
    lSerial.Visible = bVal
    txtSerial.Visible = bVal
End Sub