frmexcel.frm

1.如果在向导设置班级数为8时,此数值为班级总数

         Style           =   2  'Dropdown List
         TabIndex        =   5
         Top             =   390
         Width           =   1245
      End
      Begin VB.ComboBox Combo5 
         ForeColor       =   &H000000FF&
         Height          =   300
         Left            =   150
         Style           =   2  'Dropdown List
         TabIndex        =   4
         Top             =   390
         Width           =   1215
      End
      Begin ACTIVESKINLibCtl.SkinLabel SkinLabel3 
         Height          =   255
         Index           =   6
         Left            =   1560
         OleObjectBlob   =   "FRMEXCEL.frx":0A5A
         TabIndex        =   6
         Top             =   420
         Width           =   465
      End
      Begin ACTIVESKINLibCtl.SkinLabel SkinLabel3 
         Height          =   255
         Index           =   5
         Left            =   1560
         OleObjectBlob   =   "FRMEXCEL.frx":0AB3
         TabIndex        =   9
         Top             =   960
         Width           =   465
      End
      Begin ACTIVESKINLibCtl.SkinLabel SkinLabel3 
         Height          =   255
         Index           =   7
         Left            =   1560
         OleObjectBlob   =   "FRMEXCEL.frx":0B0C
         TabIndex        =   12
         Top             =   1500
         Width           =   465
      End
      Begin ACTIVESKINLibCtl.SkinLabel SkinLabel3 
         Height          =   255
         Index           =   8
         Left            =   1560
         OleObjectBlob   =   "FRMEXCEL.frx":0B65
         TabIndex        =   15
         Top             =   2040
         Width           =   465
      End
   End
   Begin VB.CommandButton Command2 
      Caption         =   "确定导入"
      Height          =   615
      Left            =   6720
      TabIndex        =   1
      Top             =   3330
      Width           =   1275
   End
   Begin ACTIVESKINLibCtl.Skin Skin1 
      Left            =   5820
      OleObjectBlob   =   "FRMEXCEL.frx":0BBE
      Top             =   3150
   End
   Begin VB.CommandButton Command1 
      Caption         =   "刷新列表"
      Height          =   615
      Left            =   5910
      TabIndex        =   0
      Top             =   4320
      Width           =   1275
   End
   Begin ACTIVESKINLibCtl.SkinLabel SkinLabel3 
      Height          =   375
      Index           =   4
      Left            =   5820
      OleObjectBlob   =   "FRMEXCEL.frx":4B0AD
      TabIndex        =   2
      Top             =   2460
      Width           =   3135
   End
   Begin ACTIVESKINLibCtl.SkinLabel SkinLabel3 
      Height          =   255
      Index           =   13
      Left            =   120
      OleObjectBlob   =   "FRMEXCEL.frx":4B132
      TabIndex        =   49
      Top             =   2460
      Width           =   5535
   End
End
Attribute VB_Name = "FRMEXCEL"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim fd As Field
Dim astr As String
Dim dbAdd As Database
Dim db As Database
Dim GYXE As String
Dim rs As Recordset
Dim NUM As Long
Dim FU As Long
Dim STR As String
Dim lssel As String
Dim lssela As String
Private Sub Command1_Click()
    On Error Resume Next
    Combo1.Clear
    Combo4.Clear
    Combo2.Clear
    Combo3.Clear
    Combo1.AddItem "不导入"
    Combo2.AddItem "不导入"
    Combo3.AddItem "不导入"
    Combo4.AddItem "不导入"
    Combo6.AddItem "不导入"
    Combo7.AddItem "不导入"
    Combo9.AddItem "不导入"
    Combo11.AddItem "不导入"
    List1.Clear
    Dim db As DAO.Database
    Dim oTD As DAO.TableDef
    Dim f As DAO.Field
    Set db = Workspaces(0).OpenDatabase(App.Path & "\TEMP\" & DD & ".NHB")
    Set oTD = db.TableDefs("EXCLE")
    With oTD
        lCount = .Fields.Count
        For lCtr = 0 To lCount - 1
            Combo1.AddItem oTD.Fields(lCtr).Name
            Combo2.AddItem oTD.Fields(lCtr).Name
            Combo3.AddItem oTD.Fields(lCtr).Name
            Combo4.AddItem oTD.Fields(lCtr).Name
            Combo6.AddItem oTD.Fields(lCtr).Name
            Combo7.AddItem oTD.Fields(lCtr).Name
            Combo9.AddItem oTD.Fields(lCtr).Name
            List1.AddItem oTD.Fields(lCtr).Name
        Next
    End With
    db.Close
    Set db = DBEngine.Workspaces(0).OpenDatabase(App.Path & "\TEMP\" & DD & ".NHB")
    astr = "ALTER TABLE EXCLE ADD COLUMN 不导入 TEXT(15)"
    db.Execute astr
    Set db = DBEngine.Workspaces(0).OpenDatabase(App.Path & "\TEMP\" & DD & ".NHB")
    db.Execute "UPDATE EXCLE SET 不导入=''"
    db.Close
    Combo1.ListIndex = 0
    Combo2.ListIndex = 0
    Combo3.ListIndex = 0
    Combo4.ListIndex = 0
    Combo6.ListIndex = 0
    Combo7.ListIndex = 0
    Combo9.ListIndex = 0
    Combo11.ListIndex = 0
    List1.ListIndex = 0
End Sub
Private Sub Command2_Click()
    On Error GoTo 3061
    Call Command3_Click
    Call Command4_Click
    MsgBox "自动导入操作前,程序将删除当前所有已录入的数据！！！", vbOKOnly, "警告！"
    Set db = OpenDatabase(App.Path & "\TEMP\" & DD & ".NHB")
    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
            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
            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\3.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
    FRMdatain.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