module1.bas

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

Attribute VB_Name = "Module1"
  
  Public XQhave As Integer '有几学期
  Public Xq As String    '学期
  Public Xn As Integer   ' 学年
  Global Const Tq1 = "姓名,学分,平均分,加分,德育,总分,排名"
  Global Const TqP = "姓名,平均,排名"
  Global Const TqB = "毕业表"
  Public Gnm As String ' sql
  Public Varzy As String '专业
  Public SminG As String '学期
 Public Frmputinshow As Integer
 Public Worktype As Integer
 Public Name1 As String
 Public GY As String
 Global Const TiShi = "思远提示"
 Public exit1 As Integer
 Public se As Integer
 Public frm As Form
 Public taboption As Integer
 Public xishuS As Single '每周几节课
 Public KEoption As String  '主课还是副科
 Global Const XI = "机械工程学院"
 
 Public ws As Workspace
 Public dbname As Database
 Public scoretab As TableDef, RecordTab As TableDef
 Public Lesson(10) As Field, fenField(20) As Field
 Dim namedex As Index, lessondx(2) As Index
 Dim subdxfld As Field, namedexfld As Field, lessonfld As Field
 Public i As Integer
 Public MSG As String, style As Long, title As String  'title也用于传递table'name
 
 'Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long


 'Pulic Const SWP_NOSIZE = &H5
'====================
Public Declare Function sndPlaySound Lib "winmm.dll" _
Alias "sndPlaySoundA" (ByVal lpszSoundName As String, _
ByVal uFlags As Long) As Long
'==============frmsplash.show 始终在前
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Const SWP_SHOWWINDOW = &H40
Public Const SWP_NOSIZE = &H1
 Sub Buildtab(Sbname As String)
 Dim fenrecord As Recordset
 Dim JBen As Recordset
 
  Set scoretab = dbname.CreateTableDef(Sbname)
  Set fenField(0) = scoretab.CreateField("学号", dbInteger, 2)
  
  Set fenField(1) = scoretab.CreateField("姓名", dbText, 10)
  
  scoretab.Fields.Append fenField(0)
  scoretab.Fields.Append fenField(1)
  
  '============索引
  
  Set namedex = scoretab.CreateIndex("学号")
  
  namedex.Unique = True
  Set namedexfld = namedex.CreateField("学号")
 
'=====================================
'添加到各集合中
'==========================
 namedex.Fields.Append namedexfld
 scoretab.Indexes.Append namedex
  '==========初始化frmTblStruct
 dbname.TableDefs.Append scoretab
 
 If Sbname <> "基本表" Then    ' 基本表里的"学号","姓名" 字段 复制到 新表
  Set fenrecord = dbname.OpenRecordset(Sbname)
  Set JBen = dbname.OpenRecordset("基本表")
    JBen.MoveFirst
     
For i = 1 To dbname.TableDefs("基本表").RecordCount
     fenrecord.AddNew
  fenrecord.Fields(0).Value = JBen.Fields(0).Value
  fenrecord.Fields(1).Value = JBen.Fields(1).Value
     
     JBen.MoveNext
     fenrecord.Update
     Next i

 
 
 End If

 
 End Sub
 
'================EXIT 子程序
 Sub ExitGame()
 MSG = "真的要退出？请再确认！"
 style = vbDefaultButton1 + vbInformation + vbYesNo
 If MsgBox(MSG, style, TiShi) = vbYes Then
 exit1 = 1
 Else
 exit1 = 0
   End If
 
 End Sub
 
'===============================
'启动表的程序
Sub loadBiao(name2 As String)
 
 Dim rdHave As Integer, fdHave As Integer
 
 Dim widh As Single, high As Single




frmDataGrid.Data1.DatabaseName = ("钢院学分库\" & GY & ".mdb")
If Worktype <> 2 Then _
name2 = kaishifrm.List2.List(kaishifrm.List2.ListIndex)
frmDataGrid.Data1.RecordSource = name2
frmDataGrid.Data1.Refresh
frmDataGrid.Top = 10
frmDataGrid.Left = 10
DoEvents
frmDataGrid.Label1.Caption = GY & name2
DoEvents
frmDataGrid.Show
DoEvents
 
 End Sub

'===========================
'建立学分数据表
'===========================

'Set fenField(a) = scoretab.CreateField("学号", dbText, 10)
'==========================
'建立索引
'Set namedex = scoretab.CreateIndex(" 学号 ")
'namedex.Primary = True
'namedex.Unique = True
'Set namedexfld = namedex.CreateField(" 学号 ")
 
'=====================================
'添加到各集合中
'==========================
'namedex.Fields.Append namedexfld
'scoretab.Indexes.Append namedex
'dbname.TableDefs.Append scoretab
'End Sub
'==========================打开一个表
 Sub OpenTable()
 Dim i2 As Single
On Error GoTo ac
kaishifrm.List2.Clear
For i = 0 To dbname.TableDefs.Count - 1
If Left(dbname.TableDefs(i).Name, 4) <> "MSys" And Left(dbname.TableDefs(i).Name, 4) <> "USys" Then
kaishifrm.List2.AddItem dbname.TableDefs(i).Name
  End If
Next i

    '有表吗?没有退出!
If kaishifrm.List2.ListCount > 0 Then
 
     Do Until kaishifrm.Height > 6100 '?w?
   kaishifrm.Height = 2770 + i2
   i2 = i2 + 0.9
   DoEvents
   Loop
  
End If

Exit Sub
ac:
MSG = "您要找的班级不存在,请选择“添加!”"
If Err.Number = 3024 Then
 '告诉用户出了什么事。然后清除 Err 对象。
       Beep
       MsgBox MSG   ' , "Deferred Error If List1.SelCount <= 0 Then"
        Err.Clear   ' 清除 Err 对象字段。
   ElseIf Err.Number = 91 Then
     Beep
     MsgBox MSG
     Err.Clear
   Else
   MsgBox " 发生了一未知错误！"

End If

End Sub
'==================================================
' 过程：   ObjectExists
'
' 目的：   确定一个成员是否存在
'          除了第一个参数声明为对象以外，与 MemberExists 相同，
'          这就允许传递像 VBComponents、VBProjects 等那样的集合
' 参数：
'   pColl:    要检查的集合
'   sMemName: 要检查的成员的名称（关键字）
' 输出：
'   True:  成员在集合中存在
'   False: 成员在集合中不存在
' 维护：   J$
'==================================================
Function ObjectExists(pColl As Object, sMemName As String) As Boolean
 
 Dim pObj As Object
 On Error GoTo sd
  
  Err = 0
  Set pObj = pColl(sMemName)
  ObjectExists = (Err = 0)
  
sd:
 ObjectExists = (Err = 0)
End Function

'用于addfield,tablestruct窗体
'==================选中空库
Sub SelectEmpty()
MSG = "您选中的班级本学期还未建表,请点击'确定'为其建表！ "
style = vbOKCancel + vbInformation + vbDefaultButton1
 If MsgBox(MSG, style, TiShi) = vbOK Then
  '建立学分数据表
Set scoretab = dbname.CreateTableDef(Name1)
  
  
  End If
Unload kaishifrm
End Sub

'
'======================================
Sub Showkaishi()
Unload PasswdFrm
kaishifrm.WindowState = vbNormal
kaishifrm.Show
'kaishifrm.Text2(0).SetFocus
End Sub



'========================
'建库 和 基本表
'=========================
Sub Buildku()

On Error GoTo sd
'=================================
 
  

  
'=================================
 
  
  se = 0 ' 学生数清零
  
Dim prompt As String
prompt = "请输入学生总数,最少8人!"
title = GY
  se = CInt(InputBox(prompt, title))
  If se > 6 Then
  Set ws = DBEngine.Workspaces(0)
  Set dbname = ws.CreateDatabase("钢院学分库\" & GY & ".mdb", dbLangChineseSimplified, dbVersion30)
  Buildtab ("基本表")
  MsgBox "您的班级首次使用，需建立基本表！"
  kaishifrm.File1.Refresh
  
  Frmchushi.Show
 
 
 
  Frmchushi.Caption = GY & "基本表"
  kaishifrm.Width = 5330
  kaishifrm.Height = 2770
  
   End If
  Exit Sub
sd:
  If Err.Number = 12 Then _
  Exit Sub
End Sub
Sub Putin(Worktype As Integer)
  On Error GoTo ad
  Dim have As Integer
  Set dbname = OpenDatabase("钢院学分库\" & GY & ".mdb")
     If Worktype = 3 Then
       OpenTable '子
           Exit Sub
     End If
    For i = 0 To dbname.TableDefs.Count - 1
     If dbname.TableDefs(i).Name = Name1 Then
       If Worktype = 1 Then
         Set scoretab = dbname.TableDefs(Name1)
         frmTblStruct.Show
          Exit Sub
       ElseIf Worktype = 2 Then
         Set scoretab = dbname.TableDefs(Name1)
         loadBiao (Name1)
         
         ' frmDataGrid.Show
          Exit Sub
       End If
           
     End If
     Next i
  If Worktype = 1 Then
     Beep
     MSG = "您是想为" & GY & ",建立" & Name1 & "吗? "
     style = vbDefaultButton1 + vbOKCancel
     If MsgBox(MSG, style, TiShi) = vbOK Then
  
       Buildtab (Name1) '子
            '==========================
     kaishifrm.List2.AddItem (Name1)
                  
       frmTblStruct.Show
     Else
       dbname.Close
       Exit Sub
     End If
  ElseIf Worktype = 2 Or Worktype = 3 Then
   Beep
   MsgBox "无本学期记录，如果想添加请选择“添加”!"
   Exit Sub
  End If
'=======================================
Exit Sub
ad:
'If Err.Number = 3204 Then
' 告诉用户出了什么事。然后清除 Err 对象。
      '  MSG = "该班级已存在,您是老用户!"
      '  MsgBox MSG   ' , "Deferred Error If List1.SelCount <= 0 Then"
       '  Err.Clear   ' 清除 Err 对象字段。
 '  Else
         
      If Err.Number = 3024 Then
          If Worktype <> 1 Then
            MsgBox "无本本班记录，请选择“添加”！"
            Exit Sub
          End If
          MSG = "您将建立" & GY & "学分库" & "吗? "
            style = vbDefaultButton1 + vbOKCancel
        
         If MsgBox(MSG, style, TiShi) = vbOK Then
          Buildku
        End If
        
        'MSG = "您的班级无成绩记录,请先输入成绩!"
       'MsgBox MSG   ' , "Deferred Error If List1.SelCount <= 0 Then"
       ' Err.Clear   ' 清除 Err 对象字段。
     End If

'End If

End Sub
  

   
Function vartype2(na2 As Variant)
If VarType(na2) = vbNull Then
vartype2 = 0
Else
vartype2 = na2
End If
End Function
Public Sub renew()
Dim loadway As String
loadway = dbname.Name
dbname.Close
Set dbname = OpenDatabase(loadway)
End Sub

Public Sub printline(printy As Integer, frm As Form)
Dim iline2 As Single
For iline2 = 150 To frm.Width - 200 Step 110
Printer.CurrentY = printy
'frm.CurrentY = printy
Printer.CurrentX = iline2
'frm.CurrentX = iline2

Printer.Print "_"
'frm.Print "_"
Next iline2
End Sub