frmdatain.frm

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

Dim dbAdd As Database
Dim GYXE As String
Dim rs As Recordset
Dim NUM As Long
Dim FU As Long
Dim STR As String
Dim db As Database
'Dim rs As Recordset
Dim SHFileOp As SHFILEOPSTRUCT
Private Sub ExportExcelSheetToAccess(sSheetName As String, sExcelPath As String, sAccessTable As String, sAccessDBPath As String)
    On Error GoTo 3125
    Dim db As Database
    Dim rs As Recordset
    Set db = OpenDatabase(sExcelPath, True, False, "Excel 8.0")
    Call db.Execute("Select * into [;database=" & sAccessDBPath & "]." & sAccessTable & " FROM [" & sSheetName & "$]")
3125:
    Select Case Err.Number
        Case 3125
            MsgBox "您输入的工作表名称有误", 32, "无法操作"
            FRMEXCEL.Command2.Enabled = False
            Exit Sub
        Case 3010
            MsgBox "数据已存在", 32, "无法操作"
            Exit Sub
    End Select
End Sub


Private Sub Command1_Click()
    On Error Resume Next
    Me.Enabled = False
    Cmd1.filename = ""
    Cmd1.InitDir = App.Path
    Cmd1.Flags = cdlOFNHideReadOnly
    Cmd1.Filter = "NHB库内文件(*.NHB)|*.NHB|"
    Cmd1.ShowOpen
    '        Dim SHFileOp As SHFILEOPSTRUCT
    If Cmd1.filename = "" Then
        Me.Enabled = True
        Exit Sub
    Else
        Dim db As Database
        Dim rs As Recordset
        Dim nmc As String
        Dim AMM1 As String
        MousePointer = vbHourglass
        Set db = OpenDatabase(Cmd1.filename)
        Set rs = db.OpenRecordset("SELECT * FROM COM WHERE 标记='名称'")
        nmc = rs![代码]
        db.Close
        Set db = OpenDatabase(Cmd1.filename)
        Set rs = db.OpenRecordset("SELECT * FROM COM WHERE 标记='MM1'")
        AMM1 = rs![代码]
        db.Close
        SHFileOp.wFunc = FO_DELETE
        SHFileOp.pFrom = "c:\nhb.XLS"
        SHFileOp.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMMKDIR + FOF_NOCONFIRMATION + FOF_SILENT
        Call SHFileOperation(SHFileOp)
        Set db = Workspaces(0).OpenDatabase(Cmd1.filename)
        db.Execute "SELECT " & AMM1 & " INTO [Excel 8.0;DATABASE=c:\nhb.XLS].[nhb] FROM  [学生] "
        db.Close
        MousePointer = vbDefault
        Dim 科目  As String

        科目 = "nhb"

        Dim astr As String
        Dim dbAdd As Database
        Set dbAdd = DBEngine.Workspaces(0).OpenDatabase(App.Path & "\TEMP\" & DD & ".NHB")
        astr = "DROP TABLE EXCLE"
        dbAdd.Execute astr
        dbAdd.Close
        Set dbAdd = Nothing
        ExportExcelSheetToAccess 科目, "c:\nhb.XLS", "EXCLE", App.Path & "\TEMP\" & DD & ".NHB"
        '                FRMEXCEL.Show


        '        End If

        '        On Error GoTo 32755
        '        MsgBox "自动导入操作前,程序将删除当前所有已录入的数据！！！", vbOKOnly, "警告！"
        '        Set db = OpenDatabase(App.Path & "\TEMP\" & DD & ".NHB")
        '        STR = "DELETE * from 学生"
        '        db.Execute STR
        '        db.Close
        '        Data1.DatabaseName = App.Path & "\TEMP\" & DD & ".NHB"
        '        Data1.RecordSource = XS
        '        Data1.Refresh
        '        Set dbAdd = OpenDatabase(App.Path & "\TEMP\" & DD & ".NHB")
        '        Set rs = dbAdd.OpenRecordset("SELECT * FROM 年级")
        '        GYXE = rs![班级数]
        '        dbAdd.Close
        '        Data1.DatabaseName = Cmd1.filename
        '        Data1.RecordSource = "select * FROM 学生 WHERE 班级<" & GYXE & " OR 班级=" & GYXE & ""
        '        Data1.Refresh
        '        Text1.DataField = "学号"
        '        Text2.DataField = "姓名"
        '        Text3.DataField = "班级"
        '        Text4.DataField = "学籍"
        '        Data1.Recordset.MoveFirst
        '        Select Case MsgBox("是否真的导入记录吗？", vbOKCancel, "警告！")
        '                Case vbOK
        '                        MousePointer = vbHourglass
        '                        Set db = OpenDatabase(Cmd1.filename)
        '                        Set rs = db.OpenRecordset("select * FROM 学生 WHERE 班级<" & GYXE & " OR 班级=" & GYXE & "")
        '                        NUM = 0
        '                        rs.MoveFirst
        '                        Do While Not rs.EOF()
        '                                NUM = NUM + 1
        '                                rs.MoveNext
        '                        Loop
        '                        For FU = 0 To NUM - 1
        '                                Data1.Recordset.AbsolutePosition = FU
        '                                Set dbAdd = OpenDatabase(App.Path & "\TEMP\" & DD & ".NHB")
        '                                astr = "INSERT INTO 学生 (学号,姓名,班级,学籍) VALUES ('" & Text1 & "','" & Text2 & "','" & Text3 & "','" & Text4 & "' )"
        '                                dbAdd.Execute astr
        '                                dbAdd.Close
        '                        Next FU
        '                        Dim III As Long
        '                        For III = 1 To NUM
        '                                VSFlexGrid1.TextMatrix(III, 0) = III
        '                        Next
        '                        MousePointer = vbDefault
        '                        Unload Me
        '                Case Else
        '                        Cancel = True
        '                        Unload Me
        '        End Select
        '32755:
        '        Select Case Err.Number
        '                Case 3343
        '                        MsgBox "此数据格式不对,请使用正确的NHB数据库进行导入", 32, "无法导入"
        '                        MousePointer = vbDefault
        '                        Unload Me
        '                Case 3061
        '                        MsgBox "此数据被破坏,请使用数据恢复来修复此数据库", 32, "无法导入"
        '                        MousePointer = vbDefault
        '                        Unload Me
        '                Case 3078
        '                        MsgBox "此数据格式不对或被破坏", 32, "无法导入"
        '                        MousePointer = vbDefault
        '                        Unload Me
        '        End Select
        '   On Error Resume Next
        FORNHBIN.Show
    End If
End Sub
Private Sub Command2_Click()
    On Error Resume Next
    Unload Me
End Sub
Private Sub Command3_Click()
    On Error Resume Next
    Me.Enabled = False
    Cmd1.filename = ""
    Cmd1.CancelError = True
    Cmd1.InitDir = App.Path
    Cmd1.Flags = cdlOFNHideReadOnly
    Cmd1.Filter = "EXCEL文件(*.XLS)|*.XLS|"
    Cmd1.ShowOpen
    '        Me.Caption = CMD1.Filter
    '         If CMD1.Filter = "EXCEL文件(*.XLS)|*.XLS|" Then Me.Caption = "EXCEL"
    If Cmd1.filename = "" Then
        Me.Enabled = True
        Exit Sub
    Else

        Dim 科目  As String
        Dim a
        科目 = InputBox("请输入要导入的工作表名：", "指定数据对象")
        If 科目 = "" Then

            Me.Enabled = True
            Exit Sub
        Else
            Dim astr As String
            Dim dbAdd As Database
            Set dbAdd = DBEngine.Workspaces(0).OpenDatabase(App.Path & "\TEMP\" & DD & ".NHB")
            astr = "DROP TABLE EXCLE"
            dbAdd.Execute astr
            dbAdd.Close
            Set dbAdd = Nothing
            ExportExcelSheetToAccess 科目, Cmd1.filename, "EXCLE", App.Path & "\TEMP\" & DD & ".NHB"
            FRMEXCEL.Show
        End If
    End If
    '32755:
    '        Select Case Err.Number
    '                Case 32755
    '                        Unload Me
    '        End Select
End Sub

Private Sub Form_Load()
    On Error Resume Next
    '    Skin1.LoadSkin App.Path & "\SKIN\6.sk"
    Skin1.ApplySkin Me.hwnd
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    FRMFSIN.Enabled = True
    Dim ws As Workspace
    Dim db As Database
    Dim rs As Recordset
    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