frmexcel1.frm

大型商业学分统计系统原代码说明 1.如果在向导设置班级数为8时,此数值为班级总数

    STR = "DELETE * from 学生"
    db.Execute STR
    db.Close
    Set dbAdd = OpenDatabase(App.Path & "\TEMP\" & DD & ".NHB")
    Set rs = dbAdd.OpenRecordset("SELECT * FROM 年级")
    GYXE = rs![班级数]
    dbAdd.Close
    Select Case MsgBox("是否真的导入记录吗？", vbOKCancel, "警告！")
        Case vbOK
            Set dbAdd = OpenDatabase(App.Path & "\TEMP\" & DD & ".NHB")
            STR = "DELETE * from 学生"
            dbAdd.Execute STR
            dbAdd.Close

            If Combo1.Text = "" Then Combo1.Text = "不导入"
            If Combo2.Text = "" Then Combo2.Text = "不导入"
            If Combo3.Text = "" Then Combo3.Text = "不导入"
            If Combo4.Text = "" Then Combo4.Text = "不导入"
            If Combo6.Text = "" Then Combo6.Text = "不导入"
            If Combo9.Text = "" Then Combo3.Text = "不导入"
            If Combo7.Text = "" Then Combo4.Text = "不导入"
            If Combo11.Text = "" Then Combo6.Text = "不导入"
            MousePointer = vbHourglass
            Set dbAdd = DBEngine.Workspaces(0).OpenDatabase(App.Path & "\TEMP\" & DD & ".NHB")
            astr = "INSERT INTO 学生 (学号,班级," & lssel & "姓名,学籍)SELECT EXCLE." & Combo1 & "," & Combo2 & "," & lssela & "" & Combo3 & "," & Combo4 & "  FROM EXCLE WHERE 班级<" & GYXE & " OR 班级=" & GYXE & ""
            Text1 = astr
            dbAdd.Execute astr
            dbAdd.Close
            Set dbAdd = Nothing
            MousePointer = vbDefault
            '                        FRMEXCELZH2.Command3.Enabled = False
            frmEXCELin3.Show
            Unload Me
        Case Else
            Cancel = True
            Unload Me
    End Select
3061:
    Select Case Err.Number
        Case 3061
            MsgBox "您输入的对应字段为空", 32, "无法导入"
            MousePointer = vbDefault
            Unload Me
        Case 3078
            MsgBox "对应字段数有误", 32, "无法导入"
            MousePointer = vbDefault
            Unload Me
        Case 3075
            MsgBox "字段有空格,请在EXCEL中更改后再导入", 32, "无法导入"
            MousePointer = vbDefault
            Unload Me
        Case 3346
            MsgBox "对应字段数有误", 32, "无法导入"
            MousePointer = vbDefault
            Unload Me
        Case 3063
            MsgBox "您选择的字段有重复", 32, "无法导入"
            MousePointer = vbDefault
            Unload Me
        Case 3346
            MsgBox "对应字段数有误", 32, "无法导入"
            MousePointer = vbDefault
            Unload Me
    End Select
    '      '
End Sub
Private Sub Command3_Click()
    On Error Resume Next
    lssel = ""
    For i = 0 To lstSelected.ListCount - 1
        If lstSelected.Selected(i) Then
            lssel = lssel + lstSelected.List(i) + ","
        End If
    Next i
    '  MsgBox lssel
End Sub
Private Sub Command4_Click()
    On Error Resume Next
    lssela = ""
    For i = 0 To LIST2.ListCount - 1
        If LIST2.Selected(i) Then
            lssela = lssela + LIST2.List(i) + ","
        End If
    Next i
    '  MsgBox lssela
End Sub
Private Sub Command5_Click()
    On Error Resume Next

    Unload Me
End Sub



Private Sub Form_Activate()
    On Error Resume Next
    If Command2.Enabled = False Then Unload Me
    Set db = OpenDatabase(App.Path & "\TEMP\" & DD & ".NHB")
    Set rs = db.OpenRecordset("科目")
    rs.MoveLast
    intRecCount = rs.RecordCount
    rs.MoveFirst
    For intCounter = 1 To intRecCount
        lstAll.AddItem rs![科目]
        rs.MoveNext
    Next intCounter
    lstAll.ListIndex = 0
End Sub
Private Sub Form_Load()
    On Error Resume Next
    MAIN.Enabled = False
    '    Skin1.LoadSkin App.Path & "\SKIN\8.sk"
    Skin1.ApplySkin Me.hwnd
    Call Command1_Click
End Sub
Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    Dim ws As Workspace
    Dim db As Database
    Dim rs As Recordset
    MAIN.Enabled = True
    For Each ws In Workspaces
        For Each db In ws.Databases
            For Each rs In db.Recordsets
                rs.Close
                Set rs = Nothing
            Next
            db.Close
            Set db = Nothing
        Next
        ws.Close
        Set ws = Nothing
    Next
End Sub
Private Sub CmdUp_Click()
    On Error Resume Next
    Dim nItem As Integer
    With lstSelected
        If .ListIndex < 0 Then Exit Sub
        nItem = .ListIndex
        If nItem = 0 Then Exit Sub  '不能将第一个项目向上移动
        '向上移动项目
        .AddItem .Text, nItem - 1
        '删除旧的项目
        .RemoveItem nItem + 1
        '选择刚刚被移动的项目
        .Selected(nItem - 1) = True
    End With
End Sub
Private Sub cmdDown_Click()
    On Error Resume Next
    Dim nItem As Integer
    With lstSelected
        If .ListIndex < 0 Then Exit Sub
        nItem = .ListIndex
        If nItem = .ListCount - 1 Then Exit Sub '不能将最后的项目向下移动
        '向下移动项目
        .AddItem .Text, nItem + 2
        '删除旧的项目
        .RemoveItem nItem
        '选择刚刚被移动的项目
        .Selected(nItem + 1) = True
    End With
End Sub
Private Sub cmdRightOne_Click()
    On Error Resume Next
    Dim i As Integer
    If lstAll.ListCount = 0 Then Exit Sub
    lstSelected.AddItem lstAll.Text
    i = lstAll.ListIndex
    lstAll.RemoveItem lstAll.ListIndex
    If lstAll.ListCount > 0 Then
        If i > lstAll.ListCount - 1 Then
            lstAll.ListIndex = i - 1
        Else
            lstAll.ListIndex = i
        End If
    End If
    lstSelected.ListIndex = lstSelected.NewIndex
End Sub
Private Sub cmdRightAll_Click()
    On Error Resume Next
    Dim i As Integer
    For i = 0 To lstAll.ListCount - 1
        lstSelected.AddItem lstAll.List(i)
    Next
    lstAll.Clear
    lstSelected.ListIndex = 0
End Sub
Private Sub cmdLeftOne_Click()
    On Error Resume Next
    Dim i As Integer
    If lstSelected.ListCount = 0 Then Exit Sub
    lstAll.AddItem lstSelected.Text
    i = lstSelected.ListIndex
    lstSelected.RemoveItem i
    lstAll.ListIndex = lstAll.NewIndex
    If lstSelected.ListCount > 0 Then
        If i > lstSelected.ListCount - 1 Then
            lstSelected.ListIndex = i - 1
        Else
            lstSelected.ListIndex = i
        End If
    End If
End Sub
Private Sub cmdLeftAll_Click()
    On Error Resume Next
    Dim i As Integer
    For i = 0 To lstSelected.ListCount - 1
        lstAll.AddItem lstSelected.List(i)
    Next
    lstSelected.Clear
    lstAll.ListIndex = lstAll.NewIndex
End Sub
Private Sub lstAll_DblClick()
    On Error Resume Next

    cmdRightOne_Click
End Sub
Private Sub lstSelected_DblClick()
    On Error Resume Next

    cmdLeftOne_Click
End Sub
Private Sub Up_Click()
    On Error Resume Next
    Dim nItem As Integer
    With LIST2
        If .ListIndex < 0 Then Exit Sub
        nItem = .ListIndex
        If nItem = 0 Then Exit Sub  '不能将第一个项目向上移动
        '向上移动项目
        .AddItem .Text, nItem - 1
        '删除旧的项目
        .RemoveItem nItem + 1
        '选择刚刚被移动的项目
        .Selected(nItem - 1) = True
    End With
End Sub
Private Sub Down_Click()
    On Error Resume Next
    Dim nItem As Integer
    With LIST2
        If .ListIndex < 0 Then Exit Sub
        nItem = .ListIndex
        If nItem = .ListCount - 1 Then Exit Sub '不能将最后的项目向下移动
        '向下移动项目
        .AddItem .Text, nItem + 2
        '删除旧的项目
        .RemoveItem nItem
        '选择刚刚被移动的项目
        .Selected(nItem + 1) = True
    End With
End Sub
Private Sub LeftAll_Click()
    On Error Resume Next
    Dim i As Integer
    For i = 0 To LIST2.ListCount - 1
        List1.AddItem LIST2.List(i)
    Next
    LIST2.Clear
    List1.ListIndex = List1.NewIndex
End Sub
Private Sub LeftOne_Click()
    On Error Resume Next
    Dim i As Integer
    If LIST2.ListCount = 0 Then Exit Sub
    List1.AddItem LIST2.Text
    i = LIST2.ListIndex
    LIST2.RemoveItem i
    List1.ListIndex = List1.NewIndex
    If LIST2.ListCount > 0 Then
        If i > LIST2.ListCount - 1 Then
            LIST2.ListIndex = i - 1
        Else
            LIST2.ListIndex = i
        End If
    End If
End Sub
Private Sub One_Click()
    On Error Resume Next
    Dim i As Integer
    If List1.ListCount = 0 Then Exit Sub
    LIST2.AddItem List1.Text
    i = List1.ListIndex
    List1.RemoveItem List1.ListIndex
    If List1.ListCount > 0 Then
        If i > List1.ListCount - 1 Then
            List1.ListIndex = i - 1
        Else
            List1.ListIndex = i
        End If
    End If
    LIST2.ListIndex = LIST2.NewIndex
End Sub
Private Sub RightAll_Click()
    On Error Resume Next
    Dim i As Integer
    For i = 0 To List1.ListCount - 1
        LIST2.AddItem List1.List(i)
    Next
    List1.Clear
    LIST2.ListIndex = 0
End Sub
Private Sub List1_DblClick()
    On Error Resume Next

    One_Click
End Sub
Private Sub List2_DblClick()
    On Error Resume Next

    LeftOne_Click
End Sub