frmgridmodify.frm

教务管理系统,用VB 完成,以SQL SERVER 2000作为后台数据库

 .Cells(I, 7).Value = REC(3).Value
 .Cells(I, 8).Value = REC(4).Value
 .Cells(I, 9).Value = REC(11).Value
 .Cells(I, 10).Value = REC(2).Value
 .Cells(I, 11).Value = REC(18).Value
 .Cells(I, 12).Value = REC(10).Value & "省"
 .Cells(I, 13).Value = ""
 .Cells(I, 14).Value = ""
 .Cells(I, 15).Value = REC(15).Value
 .Cells(I, 16).Value = REC(16).Value
 End With
REC.MoveNext
Next I

'处理班级数据
 'rec.MoveFirst
 
 'For I = 2 To q + 1
 ' ex.Cells(I, 1).Value = rec(7).Value
 'rec.MoveNext
 ' Next I



ex.Visible = True
exwbook.Saved = True
REC.MoveFirst

10:
Screen.MousePointer = vbArrow
Set exsheet = Nothing
Set exwbook = Nothing
Set ex = Nothing
End If

End Sub

Private Sub MNUBJK_Click()
    Dim DAT As Database
    Dim REC, RECSTUD As Recordset
    Dim SQL_STR, MARKBJ, SQL_STUD As String
    Dim IDX As New Index
    Dim TDF As TableDef
    Dim N As Long
    Dim ZDV As String
    MARKBJ = "MB" & banj
    
    On Error GoTo err
    
    '判断是否该表已存在
    Set DAT = OpenDatabase(App.Path + "\database\mark.mdb", , False)
    Set REC = DAT.OpenRecordset("select * from banjgl where BANJMC='" & MARKBJ & "'")
    If Not (REC.EOF = True And REC.BOF = True) Then MsgBox "此班级成绩库早已存在.", vbInformation + vbOKOnly, "出错提示!": REC.Close: DAT.Close: Exit Sub
    If DataForMain.Recordset.RecordCount = 0 Then MsgBox "没有数据可生成成绩数据库", vbCritical + vbOKOnly, "错误提示": REC.Close: DAT.Close: Exit Sub
    
    '添加表
    SQL_STR = "select ID AS 索引号,kecmc AS 课程名称,Xuef AS 学分,Xueq AS 学期 into " & MARKBJ & " from banjmod"
    DAT.Execute SQL_STR
    
    '将表信息添加到BANJGL表中去以便于监测
    Set REC = DAT.OpenRecordset("select id,Banjmc,XUESRS,yx from banjgl")
    If Not REC.BOF Then
    REC.MoveLast
    N = REC.Fields(0)
    End If
    REC.AddNew
    REC.Fields(0) = N + 1
    REC.Fields(1) = MARKBJ
    REC.Fields(2) = DataForMain.Recordset.RecordCount
    REC.Fields(3) = DataForMain.Recordset(6).Value
    REC.Update
    REC.Close
     
     
    '添加班级库字段到表中以组建成绩库
   
    DataForMain.Recordset.MoveFirst
    Set TDF = DAT.TableDefs(MARKBJ)
    For I = 1 To DataForMain.Recordset.RecordCount
    ZDV = DataForMain.Recordset.Fields(1).Value & Right(Trim(CStr(DataForMain.Recordset.Fields(0).Value)), 2)
    TDF.Fields.Append TDF.CreateField(ZDV, dbSingle)
    DataForMain.Recordset.MoveNext
    Next I
        
    DataForMain.Recordset.MoveFirst
    SQL_STUD = "SELECT 班级,学号,姓名 FROM STUD"
    Set RECSTUD = DAT.OpenRecordset(SQL_STUD, dbOpenDynaset)
    If Not RECSTUD.BOF Then
    RECSTUD.MoveLast
    End If
    For I = 0 To DataForMain.Recordset.RecordCount - 1
    RECSTUD.AddNew
    RECSTUD.Fields(0) = DataForMain.Recordset!班级
    RECSTUD.Fields(1) = DataForMain.Recordset!学号
    RECSTUD.Fields(2) = DataForMain.Recordset!姓名
    DataForMain.Recordset.MoveNext
    RECSTUD.Update
    Next I
    RECSTUD.Close
    
    
    
    
    
    DAT.Close
    If MsgBox("" & MARKBJ & "班级成绩数据库顺利生成,浏览数据库字段?", vbInformation + vbYesNo, "信息提示") = vbNo Then
    Exit Sub
    End If
    BANJXS = MARKBJ
    FRMLISTFIE.Show 1
    Exit Sub
    
err:
   DAT.Close
   MsgBox "没有数据可生成成绩数据库", vbCritical + vbOKOnly, "错误提示"
End Sub

Private Sub mnuDaoC_Click()
On Error GoTo err
Screen.MousePointer = 11
FileCopy App.Path + "\emptydatabase\student.mdb", "a:\student.mdb"
Dim oldStudent As Database
Dim I As Integer
Dim recOld, RECJTQKB, NEWREC As Recordset
Set oldStudent = OpenDatabase("a:\student.mdb", False, False)
Set recOld = oldStudent.OpenRecordset("zbqkb", dbOpenDynaset)
If recForMain.RecordCount <> 0 Then
    recForMain.MoveFirst
    While Not recForMain.EOF
      recOld.AddNew
      For I = 1 To recForMain.Fields.Count
        recOld.Fields(I).Value = recForMain.Fields(I - 1).Value
      Next I
      recOld.Update
      recForMain.MoveNext
    Wend
 End If
 'Set RECJTQKB = oldStudent.OpenRecordset("JTQKB", dbOpenDynaset)
 'Set NEWREC = dbStudent.OpenRecordset("jtqkb", dbOpenDynaset)
 'NEWREC.MoveFirst
 'While Not NEWREC.EOF
 '     RECJTQKB.AddNew
 '     For I = 1 To NEWREC.Fields.Count
 '       RECJTQKB.Fields(I).Value = NEWREC.Fields(I - 1).Value
 '     Next I
 '     RECJTQKB.Update
 '     NEWREC.MoveNext
 '   Wend


MsgBox "导出成功", vbInformation + vbOKOnly, "信息提示"
Screen.MousePointer = 0
Exit Sub
err:
  Screen.MousePointer = 0
  MsgBox "请检查是否软驱内有磁盘,或磁盘上是否有足够的存储空间!准备好后重试!", vbInformation + vbOKOnly, "错误提示框"
  End Sub

Private Sub MNUDATA1_Click()
On Error Resume Next
Call cmdOld_Click
End Sub

Private Sub MNUFILE1_Click()
On Error Resume Next
'Me.Hide
Unload Me
'frmQuery.Show
End Sub

Private Sub MNUHELP1_Click()
On Error Resume Next
Dim TTT  As String
Dim X
TTT = App.Path + "\help\adddata.txt"
X = Shell("Notepad " + TTT, 1)
Exit Sub
End Sub

Private Sub MNULOOK_Click()
FRMMARKEXIT.Show 1
End Sub

Private Sub MNUPRINT1_Click()
If MsgBox("将要处理数据,可能花费较长时间,请稍候……", vbInformation + vbOKCancel, "提示框") = vbCancel Then
Exit Sub
Screen.MousePointer = 0
Else
Set ex = CreateObject("excel.application")
Set exwbook = ex.Workbooks().Add
Set exsheet = exwbook.Worksheets("sheet1")
Dim REC As Recordset
Dim q As Integer
Screen.MousePointer = 11
Set REC = DataForMain.Recordset
'rec.MoveFirst
If REC.AbsolutePosition = -1 Then
MsgBox "无信息可供打印，退出！", vbExclamation, "错误信息"
GoTo 10
End If

REC.MoveLast
REC.MoveFirst
q = REC.RecordCount

ex.Caption = "学生基本信息一览"
ex.Cells(1, 5).Value = "学生基本信息查询结果报表"

ex.Cells(3, 1).Value = "学号"
ex.Cells(3, 2).Value = "姓名"
ex.Cells(3, 3).Value = "出生年月"
ex.Cells(3, 4).Value = "性别"
ex.Cells(3, 5).Value = "民族"
ex.Cells(3, 6).Value = "学历"
ex.Cells(3, 7).Value = "院系"
ex.Cells(3, 8).Value = "班级"
ex.Cells(3, 9).Value = "户口属性"
ex.Cells(3, 10).Value = "年级"
ex.Cells(3, 11).Value = "生源"
ex.Cells(3, 12).Value = "政治面貌"
ex.Cells(3, 13).Value = "特长"
ex.Cells(3, 14).Value = "身份证号码"
ex.Cells(3, 15).Value = "灵通卡号码"
ex.Cells(3, 16).Value = "宿舍"
ex.Cells(3, 17).Value = "电话"
ex.Cells(3, 18).Value = "专业"
ex.Cells(3, 19).Value = "培养方式"
ex.Cells(3, 20).Value = "毕业中学"

For I = 4 To q + 3
For J = 1 To 20
  ex.Cells(I, J).Value = REC(J - 1).Value
 Next J
 REC.MoveNext
  Next I
ex.Visible = True
exwbook.Saved = True
REC.MoveFirst

10:
Screen.MousePointer = vbArrow
Set exsheet = Nothing
Set exwbook = Nothing
Set ex = Nothing
End If

End Sub

Private Sub MNUPRNNAME_Click()
Dim RECNEW As Recordset
Dim num, I, J As Integer
FileCopy App.Path + "\printdoc\班级花名册.xls", App.Path + "\TEMPPRINT\班级花名册.xls"
Set ex = CreateObject("excel.application")
Set exwbook = ex.Workbooks().Open(App.Path + "\TEMPPRINT\班级花名册.xls")
Set exsheet = exwbook.Worksheets("sheet1")
num = DataForMain.Recordset.RecordCount
Screen.MousePointer = 11
Set RECNEW = DataForMain.Recordset
If Not (RECNEW.BOF And RECNEW.EOF) Then RECNEW.MoveFirst
ex.Cells(3, 1).Value = "院(系): " & RECNEW!院系 & " 班级:" & banj & "   班主任:      " & "   人数: " & num
'ex.Cells(3, 5) =
'ex.Cells(3, 9) =

J = 1
If Not (RECNEW.EOF And RECNEW.BOF) Then RECNEW.MoveFirst
If num >= 30 Then
For I = 1 To 25
ex.Cells(I + 5, 1) = J
ex.Cells(I + 5, 2) = RECNEW!学号
ex.Cells(I + 5, 3) = RECNEW!姓名
ex.Cells(I + 5, 4) = RECNEW!性别
RECNEW.MoveNext
J = J + 1
Next I
For I = 1 To num - 30
ex.Cells(I + 5, 6) = J
ex.Cells(I + 5, 7) = RECNEW!学号
ex.Cells(I + 5, 8) = RECNEW!姓名
ex.Cells(I + 5, 9) = RECNEW!性别
RECNEW.MoveNext
J = J + 1
Next I
Else
For I = 1 To num
ex.Cells(I + 5, 1) = J
ex.Cells(I + 5, 2) = RECNEW!学号
ex.Cells(I + 5, 3) = RECNEW!姓名
ex.Cells(I + 5, 4) = RECNEW!性别
RECNEW.MoveNext
J = J + 1
Next I

End If
ex.Visible = True
exwbook.Saved = True
Set exwbook = Nothing
Set exsheet = Nothing
Set ex = Nothing
Screen.MousePointer = 0

End Sub

Private Sub MskGrdMain_Click()
On Error Resume Next
'ID = ""
'If MskGrdMain.col = 0 Then
'    ID = MskGrdMain
'    frmChoice.Show 1
'    End If
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As ComctlLib.Button)
'On Error Resume Next
Select Case Button.Index
    Case 1
    Unload Me
    'frmQuery.Show
    Case 2
    Call MNUPRINT1_Click
    Case 3
    Call MNUDATA1_Click
    Case 4
    Call mnuDaoC_Click
    Case 5
    Call MNUBF_Click
    Case 6
    If MNUBJK.Enabled = False Then MsgBox "没有选定班级无法生成成绩库,请指定班级!", vbInformation, "错误提示": Exit Sub
    Call MNUBJK_Click
    Case 7
    Call MNULOOK_Click
    Case 8
    Call MNUHELP1_Click
End Select
End Sub