frmmain3.frm

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

      Begin VB.Menu MNUABOUT 
         Caption         =   "关于(&A)…"
      End
   End
   Begin VB.Menu mnu123 
      Caption         =   "Popup Menu"
      Visible         =   0   'False
      Begin VB.Menu MNUCOLOR 
         Caption         =   "设置背景颜色"
      End
   End
End
Attribute VB_Name = "Frmstart"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim WORD As Object
Dim dbOldStudent As Database
Dim recSource As Recordset
Dim PIC As String
Sub InitBField()
  On Error Resume Next
  XuehaoLD = False
  BasField(1) = " XH,XM,BJ,YX,XL ": BasFldCnt(1) = 5
  BasField(2) = " XH,XM,BJ,YX,XL ": BasFldCnt(2) = 5
  BasField(3) = " XH,XM,BJ ": BasFldCnt(3) = 3
  BasField(4) = " XH,XM,BJ,YX,NJ,XL,SY,LTKHM,SFZHM ": BasFldCnt(4) = 9
  BasField(5) = " XH,XM,BJ,YX,NJ,SY,LTKHM ": BasFldCnt(5) = 7
  BasField(6) = " XH,XM,XB,YX,BJ,HKSX,SS,DH ": BasFldCnt(6) = 8
  BasField(7) = " XH,XM,BJ,YX,SY,ZZMM ": BasFldCnt(7) = 6
End Sub
Private Sub cmdExit_Click()
On Error Resume Next
If MsgBox("确信要退出系统?", vbQuestion + vbYesNo) = vbNo Then Exit Sub
Dbstudent.Close
Timer4.Enabled = False
Set Frmstart = Nothing
'卸载所有窗体
Dim I As Integer
While Forms.Count > 1
    I = 0
    While Forms(I).Caption = Me.Caption
         I = I + 1
    Wend
    Unload Forms(I)
Wend
Unload Me
End
End Sub
Private Sub Form_Load()
On Error Resume Next
'SF1.Left = 0
'SF1.Top = 0
'SF1.Width = Screen.Width
'GifAni1.Top = -100
'GifAni1.Left = Screen.Width - 740
 InitBField  '后面要用
Set Dbstudent = OpenDatabase(App.Path + "\database\student.mdb", True, False, ";PWD=62414968;")
Open App.Path + "\SYSTEM\PIC.TXT" For Input As #1
Input #1, PIC
Close #1
'Frmstart.Picture = LoadPicture(PIC)
Dim col As String
Open App.Path + "\system\winpath.txt" For Input As #1
Input #1, col
Close #1
App.HelpFile = App.Path + "\help\student.hlp"
FlatBar1.SetToolBAar Toolbar1, 2
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Set Frmstart = Nothing
Dim I As Integer
While Forms.Count > 1
    I = 0
    While Forms(I).Caption = Me.Caption
         I = I + 1
    Wend
    Unload Forms(I)
Wend
Unload Me
End

End Sub

Private Sub MNUBASE1_Click()
frmBaseInput.Show 1
End Sub

Private Sub MNUBASE2_Click()
frmGridModify.Show 1
End Sub

Private Sub MNUBASE3_Click()
frmQuery.Show 1
End Sub

Private Sub MNUBASE4_Click()
frmCount.Show 1
End Sub

Private Sub MNUBXKC_Click()
FRMMARKIN.Show 1
End Sub

Private Sub MNUCANCEL_Click()
MNUCANCEL.Checked = True
Frmstart.Picture = LoadPicture("")
Dim PIC As String
Open App.Path + "\SYSTEM\PIC.TXT" For Output As #1
PIC = ""
Write #1, PIC
Close #1
End Sub

Private Sub MNUCONGDU_Click()
FRMCONGDU.Show 1
'GSDATABASE = App.Path + "\DATABASE\MARK.MDB"
'GSRECORDSOURCE = "XXKC"
End Sub

Private Sub mnuDataDR1_Click()
On Error GoTo err
Dim AA As Boolean
AA = FileExists("A:\STUDENT.MDB")
If AA = False Then
MsgBox "软盘上不存在数据库文件,请检查软盘上内容!", vbCritical, "出错信息"
Exit Sub
Else
'End If
If MsgBox("您确信开始导入数据？", vbQuestion + vbYesNo) = vbNo Then Exit Sub
Set dbOldStudent = OpenDatabase("a:\student.mdb", False, False)
MsgBox "开始导入基本信息表中内容,请等待......", vbInformation, "导入数据过程之一"
Screen.MousePointer = 11
CopyRecordXH "zbqkb", 20
MsgBox "开始导入家庭情况表中内容,请等待......", vbInformation, "导入数据过程之二"
Screen.MousePointer = 11
CopyRecordXH "jtqkb", 12
dbOldStudent.Close
Exit Sub
End If
err:
MsgBox "导入过程出错，请检查软盘是否插入软驱或软盘上是否存在数据库文件！", vbCritical, "出错提示"
Screen.MousePointer = 0
End Sub


Private Sub mnuDataRC1_Click()
On Error GoTo err
Dim AA As Boolean
AA = FileExists("A:\STUDENT.MDB")
If AA = True Then
        
        If MsgBox("软盘上已存在相同的数据文件,是否要覆盖该文件?", vbQuestion + vbYesNo) = vbNo Then
           Exit Sub
        End If
 Else
   
        DrvFact1.DriveLetter = "A:"
        If DrvFact1.FreeSize <= 1 Then
        MsgBox "软盘是没有足够的空间,请换插一张空盘!", vbInformation + vbOKOnly, "错误信息"
        Exit Sub
        End If
End If

Screen.MousePointer = 11
'MsgBox "先复制空数据库到软盘,确定后请等待......", vbInformation + vbOKOnly, "数据导出过程步骤之一"
FileCopy App.Path + "\emptydatabase\student.mdb", "a:\student.mdb"
MsgBox "开始导出基本情况表中数据到软盘,确定后请等待......", vbInformation + vbOKOnly, "数据导出过程之一"
CopyRecordOut0 "zbqkb", 20
MsgBox "开始导出家庭情况表中数据到软盘,确定后请等待......", vbInformation + vbOKOnly, "数据导出过程之二"
CopyRecordOut0 "jtqkb", 12

Screen.MousePointer = 0
Exit Sub
err:
MsgBox "请检查是否软盘为空或是否软盘插入软驱中!", vbCritical + vbOKOnly, "出错提示"
End Sub

Private Sub MNUEXIT_Click()
On Error Resume Next
If MsgBox("确信要退出系统?", vbQuestion + vbYesNo) = vbNo Then Exit Sub
Dbstudent.Close
'Timer4.Enabled = False
Set Frmstart = Nothing
'卸载所有窗体
Dim I As Integer
While Forms.Count > 1
    I = 0
    While Forms(I).Caption = Me.Caption
         I = I + 1
    Wend
    Unload Forms(I)
Wend
Unload Me
End
End Sub
Private Sub MNUHELP2_Click()
Dim TTT  As String
TTT = App.Path + "\help\STUDENT.hlp"
X = Shell("winhelp " + TTT, 1)
End Sub

Private Sub MNUHELP3_Click()
Frmhelp.Show 1
End Sub

Private Sub MNUMARK1_Click()
frmMark.Show 1
End Sub

Private Sub MNUMARKADD_Click()
FRMDATABASE.Show 1
End Sub

Private Sub MNUOP_Click()
On Error Resume Next
 Dim sFile As String
    With CDlog1
        'To Do
        '设置 common dialog 控件的标志和属性
        .Filter = "文本文件(*.txt)|*.txt|Word文档" & _
                  "(*.doc)|*.doc|Excel文档(*.xls)|*.xls"
' 指定缺省的过滤器
        .FilterIndex = 2
        .ShowOpen
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With

'文本文档
If Right(Trim(sFile), 3) = "txt" Then
Dim X
X = Shell("Notepad " + sFile, 1)
End If

'Word文档
If Right(Trim(sFile), 3) = "doc" Then
Set WORD = CreateObject("Word.BASIC")
With WORD
     .FILEOPEN sFile
     .APPSHOW
End With
Set WORD = Nothing
End If

'EXCEL文档
If Right(Trim(sFile), 3) = "xls" Then
Dim Excel As Object
Dim WorkSheet As Object
Dim WorkBook As Object
Set Excel = CreateObject("Excel.application")
Excel.Workbooks.Open sFile
Set WorkBook = Excel.ActiveWorkbook
Set WorkSheet = Excel.ActiveSheet
Excel.Visible = True
WorkBook.Saved = True
Set WorkSheet = Nothing
Set WorkBook = Nothing
Set Excel = Nothing
End If
End Sub

Private Sub MNUQUERY_Click()
FRMSQLMARK.Show 1
End Sub

Private Sub MNUWJ11_Click()
 On Error Resume Next
 Dim sFile As String
    With CDlog1
        'To Do
        '设置 common dialog 控件的标志和属性
        .Filter = "BMP图像格式(*.BMP)|*.BMP|JPG图像格式" & _
                  "(*.JPG)|*.JPG|wmf图像格式(*.wmf)|*.wmf|所有文件(*.*)|*.*"
' 指定缺省的过滤器
        .FilterIndex = 2
        .ShowOpen
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With
Frmstart.Picture = LoadPicture(sFile)
Open App.Path + "\SYSTEM\PIC.TXT" For Output As #1
Write #1, sFile
Close #1
MNUCANCEL.Checked = False

End Sub

Private Sub MNUWJ12_Click()
frmSystemUserModify.Show 1
End Sub

Private Sub MNUWJ13_Click()
frmSystemNewUser.Show 1
End Sub

Private Sub MNUWJ14_Click()
Dim ABC As String
Dim DBSTU As Database
Dim Recuser As Recordset
10:
ABC = InputBox("请输入'系统管理员'的密码:", "管理员权限")
If ABC = "" Then Exit Sub
If ABC = "yiyou" Then
Frmdefine.Show 1
Exit Sub
End If
Set DBSTU = OpenDatabase(App.Path + "\database\student.mdb", True, False, ";PWD=62414968;")
Set Recuser = DBSTU.OpenRecordset("select * from user", dbOpenSnapshot)
sqlFind = "user='系统管理员' and pwd='" + Trim(ABC) + "'"
Recuser.FindFirst sqlFind
If Recuser.NoMatch Then
MsgBox "密码错误,重试!", vbExclamation, "错误提示"
GoTo 10
Else
Frmdefine.Show 1
End If

End Sub

Public Sub CopyRecordXH(ByVal REC As String, ByVal Number As Integer)
'生成recsourc表
On Error Resume Next
Dim sqlForCopy As String
Dim recSource As Recordset
Dim recDest As Recordset
Dim recRepeat As Recordset
Dim sqlDest As String
sqlForCopy = "select * from " + Trim(REC) + ""
Set recSource = dbOldStudent.OpenRecordset(sqlForCopy, dbOpenSnapshot)

If recSource.RecordCount > 0 Then
'处理重复数据并复制数据
    '读第一条记录
    recSource.MoveLast
    recSource.MoveFirst
    sqlDest = "select top 1 * from " + Trim(REC) + " where xh='" + Trim(recSource!XH) + "'"
    Set recRepeat = Dbstudent.OpenRecordset(sqlDest, dbOpenSnapshot)
    If recRepeat.RecordCount > 0 Then
        If MsgBox("您确定替换" & "" + Trim(recRepeat!XM) + "", vbInformation + vbOKCancel) = vbOK Then
            sqlDest = "delete * from " + Trim(REC) + " where xh='" + Trim(recSource!XH) + "'"
            Dbstudent.Execute sqlDest
             '复制第一条记录
            Set recDest = Dbstudent.OpenRecordset("" + Trim(REC) + "")
            recDest.AddNew
            For K = 1 To Number
              recDest.Fields(K).Value = recSource.Fields(K).Value
            Next K
            recDest.Update
        End If
    Else
        Set recDest = Dbstudent.OpenRecordset("" + Trim(REC) + "")
        recDest.AddNew
        For K = 1 To Number
          recDest.Fields(K).Value = recSource.Fields(K).Value
        Next K
        recDest.Update
    End If
    '处理余下记录
    For I = 1 To recSource.RecordCount - 1
      recSource.MoveNext
      sqlDest = "select top 1 * from " + Trim(REC) + " where xh='" + Trim(recSource!XH) + "'"
      Set recRepeat = Dbstudent.OpenRecordset(sqlDest, dbOpenSnapshot)