开始.frm

我编的学分管理程序,安装包原代码都有!VB入门的好东西

End Sub

Private Sub MNUDISPLAY_Click()
On Error GoTo b0
 
loadBiao (Name1)
Exit Sub
b0:
MsgBox "抱歉,您没有读取权限"
End Sub


Private Sub MNUTJ_Click() '统计学分

On Error GoTo ao
Dim ORDER As Integer '把(主,副)可排序
Dim XI(20) As Single
Dim xishu(20)

 Dim fenmu  As Single
Dim S As Integer
Dim fen As Single '统计总分用
Dim fenTJ As Single '统计学分用
Dim fentj2 As Single '统计不及格学分用
Dim fld  As Field
Dim ling1 As Integer
 If scoretab.RecordCount <= 4 Then
    MsgBox "学生太少,不予统计!"
  Exit Sub
 ElseIf scoretab.Fields.Count <= 3 Then
   MsgBox "课程太少,不予统计!"
  Exit Sub
 End If
  '=========================
   Set fld = scoretab.CreateField
   fld.Name = "学分"
 If ObjectExists(scoretab.Fields, fld.Name) Then
     MSG = "已经统计过,你想已前的统计记录将被覆盖!"
     style = vbOKCancel
      If MsgBox(MSG, style, TiShi) = vbCancel Then
       Exit Sub
      Else
      '=======================重新统计
       scoretab.Fields.Delete ("学分") '删除原"学分"
       Set fld = scoretab.CreateField("学分")
      
     End If
   End If
     '===================
     
  
  fld.Required = True '允许非空
  fld.Type = dbSingle
  fld.Size = 4
 
  scoretab.Fields.Append fld
     
     '============
     Set fenrecord1 = scoretab.OpenRecordset
  '==============
  fenrecord1.MoveFirst
 
  S = scoretab.Fields.Count - 3  '有几科
  If S = 0 Then
  MsgBox "记录太少!"
  fenrecord1.Close
  Exit Sub
  End If
  fenmu = 0
   PBar1.Value = 1
 For i = 2 To S + 1

 XI(i) = vartype2(fenrecord1.Fields(i).Value)
 
 If Right(Trim(fenrecord1.Fields(i).Name), 3) = "(副)" Then
 XI(20) = XI(i) / 0.8
 fenmu = fenmu + XI(20)
 Else
 fenmu = fenmu + XI(i)
 End If
Next i
fenrecord1.MoveNext
Fme1.Visible = True
PBar1.Visible = True
Do Until fenrecord1.EOF
fenTJ = 0

ORDRE = 0
For i = 2 To S + 1

 If Right(fenrecord1.Fields(i).Name, 1) = ")" And Left(fenrecord1.Fields(i).Name, 1) <> "(" Then
   
   If InStr(1, fenrecord1.Fields(i).Value, "/", 1) <> 0 Then

   fentj2 = Left(fenrecord1.Fields(i).Value, InStr(1, fenrecord1.Fields(i).Value, "/", 1) - 1)
   fenTJ = fenTJ + fentj2 * XI(i)
   Else
    'If vartype2(fenrecord1.Fields(i).Value) <> 0 Then
   fenTJ = fenTJ + vartype2(fenrecord1.Fields(i).Value) * XI(i)
   End If

    If ling1 < 168 Then
    ling1 = PBar1.Value
    PBar1.Value = ling1 + 1
    DoEvents
    Else
    ling = 0
    End If
  Else
  End If
Next i

'==========显示进程
'.Value = PBar1.Value + 1
'==================


If fenmu = 0 Then
MsgBox "课时为零!"
Fme1.Visible = False
PBar1.Visible = False

fenrecord1.Close
Exit Sub
End If



fenTJ = fenTJ / fenmu * 0.8
fenrecord1.Edit
 fenrecord1!学分 = Format(fenTJ, "##.00")
 fenrecord1.Update
fenrecord1.MoveNext
Loop
fenrecord1.Close

scoretab.Fields("学号").OrdinalPosition = 0
scoretab.Fields("姓名").OrdinalPosition = 1
ORDER = 2
For i = 2 To scoretab.Fields.Count - 1
If Right(scoretab.Fields(i).Name, 1) = ")" Then
scoretab.Fields(i).OrdinalPosition = ORDER
   ORDER = ORDER + 1
End If
Next i


Fme1.Visible = False
PBar1.Visible = False

MsgBox "统计完毕!"





Exit Sub
ao:
fenrecord1.Close
MsgBox "操作有误，请重来！"
End Sub
'=======统计总分
Private Sub MNUTJZ_Click()
Dim SS As Integer '共有几科

Dim fenmu  As Single
Dim a1(10) As Integer '记录统计2的字段号
Dim S As Integer
Dim fen As Single
Dim fenTJ As Single
Dim fld  As Field
 Dim dai(200) As Single
'On Error GoTo so

If ObjectExists(scoretab.Fields, "学分") = True And ObjectExists(scoretab.Fields, "加分") = True And ObjectExists(scoretab.Fields, "德育") = True Then
     '=========================
       'Set fld = scoretab.CreateField
       'fld.Name = "总分"
If ObjectExists(scoretab.Fields, "总分") Then
       MSG = "已经统计过,你想已前的统计记录将被覆盖!"
       style = vbOKCancel
       If MsgBox(MSG, style, TiShi) = vbCancel Then
       Exit Sub
       Else
      '=======================重新统计
       scoretab.Fields.Delete ("总分") '删除原"总分分"
       
       End If
        
   End If
     '===================
    Set fld = scoretab.CreateField("总分")
       fld.Required = False '允许非空
       fld.Type = dbSingle
        fld.Size = 4
 
  scoretab.Fields.Append fld
If ObjectExists(scoretab.Fields, "排名") Then
      
       scoretab.Fields.Delete ("排名")
       
     
    End If
     
    '=======================重新统计

  
     
     '============
  Set fenrecord1 = scoretab.OpenRecordset
  '==============
  fenrecord1.MoveFirst
  fenrecord1.MoveNext
 '=========
 k = 1
   For i = 2 To scoretab.Fields.Count - 1
   
  If Right(fenrecord1.Fields(i).Name, 1) <> ")" And Left(fenrecord1.Fields(i).Name, 2) <> "平均" Then
      a1(k) = i
      k = k + 1 '有k-1科
  End If
   Next i
 '=====
 Do Until fenrecord1.EOF
  For i = 1 To k - 1
  If VarType(fenrecord1.Fields(a1(i)).Value) = vbNull Then
 fen = 0 + fen
  Else
 fen = fenrecord1.Fields(a1(i)).Value + fen
  End If
  Next i
 
 '有k-1科
 fenrecord1.Edit
 fenrecord1!总分 = Format(fen, "#00.0#")
 fenrecord1.Update
 fenrecord1.MoveNext
 fen = 0

Loop


'================统计完毕后进行重排行,(各科)(学分)(德育)(加,减分),(总分)

SS = scoretab.Fields.Count



fenrecord1.Close


scoretab.Fields("总分").OrdinalPosition = SS + 2

'Call dai1(scoretab, fenrecord1, "加分")


scoretab.Fields("加分").OrdinalPosition = SS + 1

'Call dai(scoretab, fenrecord1, "德育")
scoretab.Fields("德育").OrdinalPosition = SS
'Call dai(scoretab, fenrecord1, "学分")
scoretab.Fields("学分").OrdinalPosition = SS - 1


'fenrecord1.Close

  'Set fld = scoretab.CreateField
   '    fld.Name = "排名"




MsgBox "统计完毕!"
Else
MsgBox "需要的科目不全!"
End If
'==============将删去的"排名"加上
Set fld = scoretab.CreateField("排名", dbSingle, 4)
       fld.Required = False '允许非空
         fld.Type = dbSingle
          fld.Size = 4
 
  scoretab.Fields.Append fld







Exit Sub
so:
 MsgBox "操作有误，请重来！"
End Sub



'Private Sub NNUclose_Click()

'Set frm = FatherFrm
'ExitGame

'End Sub


'======================
' show_up 子程序 “表的属性”
Sub show_up(A As String)

kaishifrm.lablshow(1).Caption = dbname.TableDefs(A).DateCreated
kaishifrm.lablshow(2).Caption = dbname.TableDefs(A).LastUpdated


kaishifrm.lablshow(4).Caption = dbname.TableDefs(A).RecordCount - 1 & "人"
End Sub

Private Sub TJby_Click()
'On Error GoTo lo

Dim PJrecord As Recordset
Dim BYrecord As Recordset
Dim tabs As TableDef
Dim fieldBY As Field
Dim Zname As String, z2name As String '暂时命名
Dim P(100) As Single
Dim b As Integer
If ObjectExists(dbname.TableDefs, "毕业表") Then
MsgBox "已经统计过,请删除毕业表后再统计!"
Exit Sub
End If


XQhave = List2.ListCount - 1

For i = 1 To XQhave
  Zname = "第" & i & "学期学分记录表"
  z2name = "总分" & i
'===================看似多余,

If ObjectExists(dbname.TableDefs(Zname), "总分") = False Then
   MsgBox Zname & "没有统计过“总分”!"
   Exit Sub
  End If
Next i
  Buildtab ("毕业表")
  List2.AddItem "毕业表"
  For i = 1 To XQhave
  Zname = "第" & i & "学期学分记录表"
  z2name = "总分" & i
'===================
Set fieldBY = scoretab.CreateField(z2name, dbSingle, 5)
Set PJrecord = dbname.OpenRecordset(Zname)
  scoretab.Fields.Append fieldBY
  
  Set BYrecord = dbname.OpenRecordset("毕业表")
  PJrecord.MoveLast
  PJrecord.MoveFirst
  
For b = 1 To dbname.TableDefs(Zname).RecordCount
  BYrecord.Edit
  BYrecord.Fields(i + 1).Value = vartype2(PJrecord.Fields("总分").Value)
  PJrecord.MoveNext
  BYrecord.Update
  BYrecord.MoveNext
Next b
  PJrecord.Close
   BYrecord.Close
Next i

Set fieldBY = scoretab.CreateField("平均分", dbSingle, 5)

 scoretab.Fields.Append fieldBY
 Set fieldBY = scoretab.CreateField("排名", dbSingle, 4)

 scoretab.Fields.Append fieldBY
 Set BYrecord = dbname.OpenRecordset("毕业表")
 Do Until BYrecord.EOF
    P(i) = 0
  For b = 1 To XQhave

   P(i) = vartype2(BYrecord.Fields(b + 1).Value) + P(i)

 
 Next b
 BYrecord.Edit
 BYrecord.Fields(XQhave + 2).Value = Format(P(i) / XQhave, "##0.00")
 BYrecord.Update
 BYrecord.MoveNext
 
Loop


 
  


BYrecord.Close

Exit Sub
lo:
MsgBox "有错误!"
End Sub
'=========子程序


Private Sub TJSP_Click()
'On Error GoTo ao
Dim ORDER As Integer '把(主,副)可排序


 
 Dim fenmu  As Single
Dim S As Integer
Dim fen As Single '统计总分用
Dim fenTJ As Single '统计学分用
Dim fentj2 As Single '统计不及格学分用
Dim fld  As Field
Dim ling1 As Integer
 If scoretab.RecordCount <= 4 Then
    MsgBox "学生太少,不予统计!"
  Exit Sub
 ElseIf scoretab.Fields.Count <= 3 Then
   MsgBox "课程太少,不予统计!"
  Exit Sub
 End If
  '=========================
   Set fld = scoretab.CreateField
   fld.Name = "平均分"
 If ObjectExists(scoretab.Fields, fld.Name) Then
     MSG = "已经统计过,你想已前的统计记录将被覆盖!"
     style = vbOKCancel
      If MsgBox(MSG, style, TiShi) = vbCancel Then
       Exit Sub
      Else
      '=======================重新统计
       scoretab.Fields.Delete ("平均分") '删除原"分"
       Set fld = scoretab.CreateField("平均分")
      
     End If
   End If
     '===================
     
  
  fld.Required = True '允许非空
  fld.Type = dbSingle
  fld.Size = 4
 
  scoretab.Fields.Append fld
     
     '============
     Set fenrecord1 = scoretab.OpenRecordset
  '==============
  fenrecord1.MoveFirst
 

  fenmu = 0
   PBar1.Value = 1
 
fenrecord1.MoveNext
Fme1.Visible = True
PBar1.Visible = True
Do Until fenrecord1.EOF
fenTJ = 0

ORDRE = 0
For i = 2 To fenrecord1.Fields.Count - 1

 If Right(Trim(fenrecord1.Fields(i).Name), 1) = ")" Then
   
   If InStr(1, fenrecord1.Fields(i).Value, "/", 1) <> 0 Then

   fentj2 = Left(fenrecord1.Fields(i).Value, InStr(1, fenrecord1.Fields(i).Value, "/", 1) - 1)
   fenTJ = fenTJ + fentj2
   fenmu = fenmu + 1
   Else
    'If vartype2(fenrecord1.Fields(i).Value) <> 0 Then
   fenTJ = fenTJ + vartype2(fenrecord1.Fields(i).Value)
    fenmu = fenmu + 1
   End If
   
   
'==========显示进程
    If ling1 < 168 Then
    ling1 = PBar1.Value
    PBar1.Value = ling1 + 1
    DoEvents
    Else
    ling = 0
    End If
  Else
  End If
  
  
Next i

'==================

fenTJ = fenTJ / fenmu
fenmu = 0
fenrecord1.Edit
 fenrecord1![平均分] = Format(fenTJ, "##.00")
 fenrecord1.Update
fenrecord1.MoveNext
Loop
fenrecord1.Close

scoretab.Fields("学号").OrdinalPosition = 0
scoretab.Fields("姓名").OrdinalPosition = 1
ORDER = 2
For i = 2 To scoretab.Fields.Count - 1
If Right(scoretab.Fields(i).Name, 1) = ")" Then
scoretab.Fields(i).OrdinalPosition = ORDER
   ORDER = ORDER + 1
End If
Next i
scoretab.Fields("平均分").OrdinalPosition = ORDER

Fme1.Visible = False
PBar1.Visible = False

MsgBox "统计完毕!"





Exit Sub
ao:
fenrecord1.Close
MsgBox "操作有误，请重来！"
End Sub