frmbase.frm

这是别人的数据库课程设计

VERSION 5.00
Begin VB.Form frmBase 
   BorderStyle     =   4  'Fixed ToolWindow
   Caption         =   "基本表维护"
   ClientHeight    =   4200
   ClientLeft      =   45
   ClientTop       =   285
   ClientWidth     =   4755
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MDIChild        =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   4200
   ScaleWidth      =   4755
   ShowInTaskbar   =   0   'False
   Begin VB.Frame Frame1 
      Caption         =   "基本表信息维护"
      Height          =   3975
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   4455
      Begin VB.CommandButton cmdQuit 
         Caption         =   "退出"
         Height          =   495
         Left            =   3480
         TabIndex        =   5
         Top             =   2160
         Width           =   855
      End
      Begin VB.CommandButton cmdShow 
         Caption         =   "显示"
         Height          =   495
         Left            =   3480
         TabIndex        =   4
         Top             =   960
         Width           =   855
      End
      Begin VB.CommandButton cmdDel 
         Caption         =   "删除"
         Height          =   495
         Left            =   3480
         TabIndex        =   3
         Top             =   1560
         Width           =   855
      End
      Begin VB.CommandButton cmdAdd 
         Caption         =   "添加"
         Height          =   495
         Left            =   3480
         TabIndex        =   2
         Top             =   360
         Width           =   855
      End
      Begin VB.ListBox lstBase 
         Height          =   3480
         Left            =   120
         TabIndex        =   1
         Top             =   360
         Width           =   3255
      End
   End
End
Attribute VB_Name = "frmBase"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim sName As String  '保存输入值
Dim sTable As String '保存表的名称

Private Sub cmdAdd_Click()
On Error GoTo ErrMsg
sName = InputBox("请输入要录入的" & Me.Caption, Me.Caption & "录入", "")
If sName = "" Then
   Exit Sub
End If
'根据窗体的标题得出基本表的名字，完全可以用其他方法
Select Case Me.Caption
  Case "专业"
      sTable = "Speciality"
  Case "民族"
      sTable = "Nation"
End Select
'根据当前输入到表中查询
Set adoRS = adoCon.Execute("Select Count(*) From " & sTable & " Where Name='" & sName & "'")
'若当前输入的值在表中已经存在，给出系统提示
If adoRS(0) > 0 Then
   MsgBox "名称为：" & sName & "的记录，在" & Me.Caption & "表中已经存在！", vbOKOnly + vbExclamation, "系统提示"
   sName = ""
   Exit Sub
End If
'若当前输入的值在表中不存在，则插入到应的表中
adoCon.Execute ("Insert Into " & sTable & " Values('" & sName & "')")
Set adoRS = adoCon.Execute("Select * From " & sTable & " Order By Name")
'刷新显示
lstBase.Clear
Do While Not adoRS.EOF
   lstBase.AddItem adoRS(0)
   adoRS.MoveNext
Loop
'错误处理
ErrMsg:
  If Err.Number <> 0 Then
     MsgBox Err.Number & Err.Description, vbOKOnly + vbCritical, "出错提示"
     Exit Sub
  End If
End Sub

Private Sub cmdDel_Click()
On Error GoTo ErrMsg
Dim sMsg As String  '保存对话显示信息
Dim SQL As String   '保存SQL语句
'因为不按“添加”或“删除”sTable没有值，列表中也没有数据显示，故可省略Select
If lstBase.Text = "" Then
  '没有显示数据，也就表示没有选择数据项，故什么也不做
  Exit Sub
Else
   sMsg = "您真的要删除 《" + lstBase.Text + " 》 吗？"
   If MsgBox(sMsg, vbQuestion + vbYesNo, "删除询问") = vbYes Then
      SQL = "Delete From " & sTable & " Where Name='" & lstBase.Text & "'"
      adoCon.Execute (SQL)
      lstBase.RemoveItem lstBase.ListIndex
   End If
End If
ErrMsg:
  If Err.Number <> 0 Then
     MsgBox Err.Number & Err.Description, vbOKOnly + vbCritical, "出错提示"
     Exit Sub
  End If
End Sub

Private Sub cmdQuit_Click()
Unload Me
End Sub

Private Sub cmdShow_Click()
On Error GoTo ErrMsg
'根据窗体的标题得出基本表的名字，完全可以用其他方法
Select Case Me.Caption
  Case "专业"
      sTable = "Speciality"
  Case "民族"
      sTable = "Nation"
End Select
Set adoRS = adoCon.Execute("Select * From " & sTable & " Order By Name")
lstBase.Clear
Do While Not adoRS.EOF
   lstBase.AddItem adoRS(0)
   adoRS.MoveNext
Loop
'错误处理
ErrMsg:
  If Err.Number <> 0 Then
     MsgBox Err.Number & Err.Description, vbOKOnly + vbCritical, "出错提示"
     Exit Sub
  End If
End Sub

Private Sub Form_Load()
'用代码使子窗体居中
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2 - 800
'清空两个变量
sName = ""
sTable = ""
End Sub