frmmain.frm

创建Access数据库及字段,为学员深入了解数据库编程语言提供方便。

VERSION 5.00
Begin VB.Form frmMain 
   Caption         =   "Columns"
   ClientHeight    =   3075
   ClientLeft      =   60
   ClientTop       =   465
   ClientWidth     =   4050
   BeginProperty Font 
      Name            =   "Arial"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   3075
   ScaleWidth      =   4050
   StartUpPosition =   2  '屏幕中心
   Begin VB.TextBox txtLoanee 
      Height          =   315
      Left            =   210
      TabIndex        =   1
      ToolTipText     =   "输入字符串，回车保存"
      Top             =   120
      Width           =   3600
   End
   Begin VB.ListBox lstColumn 
      Height          =   2370
      ItemData        =   "frmMain.frx":0ECA
      Left            =   210
      List            =   "frmMain.frx":0ECC
      Sorted          =   -1  'True
      TabIndex        =   0
      ToolTipText     =   "双击删除"
      Top             =   450
      Width           =   3600
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim db As Database
Dim rs As Recordset

'********************************************************************
'*北京赫尔波软件公司                                                *
'*                                                                  *
'*如果文件夹中没有数据库，启动软件时软件自动初始化AutoCID.mdb数据库 *
'*调用CreateDB建库文件。                                            *
'*                                                                  *
'*http://www.bjhelper.com                                           *
'*[e-mail]                                                     *
'*                                                                  *
'********************************************************************
Private Sub Form_Load()
  If Not FileExists(App.Path & "\AutoCID.mdb") Then
    MsgBox "文件夹中没有数据库，新的数据库创建成功。", , "创建数据库"
    CreateDB '调用创建数据库文件
    Else
    Set db = OpenDatabase(App.Path & "\AutoCID.mdb")
  End If
  Call Initialize '读取列表文件
End Sub

'列表文件调用Initialize到Form
Private Sub Initialize()
'读表文件，数据表ColumnList
Set rs = db.OpenRecordset("ColumnList")
If rs.RecordCount > 0 Then
    rs.MoveFirst
        Do Until rs.EOF
        '保存到数据表ColumnList，写入字段Columns
        lstColumn.AddItem rs!Columns
        rs.MoveNext
        Loop
    rs.Close
End If
End Sub

'创建数据库文件
Private Sub CreateDB()
Dim td As TableDef
Dim fd As Field
Set db = CreateDatabase(App.Path & "\AutoCID.mdb", dbLangGeneral, dbEncrypt)

'主表idlist
Set td = db.CreateTableDef("idlist")
   '建字段
    Set fd = td.CreateField("DateTime", dbDate)
    td.Fields.Append fd
   '增加字段
    db.TableDefs.Append td
    Set fd = td.CreateField("CallerID", dbText)
    td.Fields.Append fd
'客户信息表ManInfo
Set td = db.CreateTableDef("ManInfo")
    Set fd = td.CreateField("CallerID", dbText)
    td.Fields.Append fd
    
    Set fd = td.CreateField("Name", dbText)
    td.Fields.Append fd
    db.TableDefs.Append td

'字段表ColumnList
Set td = db.CreateTableDef("ColumnList")
    Set fd = td.CreateField("Columns", dbText)
    td.Fields.Append fd
    db.TableDefs.Append td
db.Close
Set db = OpenDatabase(App.Path & "\AutoCID.mdb")
End Sub

'类模块
Function FileExists(FullFileName As String) As Boolean
    On Error GoTo MakeF
        Open FullFileName For Input As #1
        Close #1
        FileExists = True
    Exit Function
MakeF:
        
        FileExists = False
    Exit Function
End Function

'窗体退出
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
rs.Close
db.Close
End Sub

'双击文件删除
Private Sub lstColumn_DblClick()
If lstColumn.ListCount = 0 Then Exit Sub
If MsgBox("是否删除 [" & lstColumn.List(lstColumn.ListIndex) & "] 数据文件?", vbYesNo) = vbYes Then
    Set rs = db.OpenRecordset("SELECT * From [ColumnList] WHERE Columns='" & lstColumn.List(lstColumn.ListIndex) & "';")
    If rs.RecordCount > 0 Then
        rs.Delete
        lstColumn.RemoveItem lstColumn.ListIndex
        Else
        MsgBox "没有记录"
        End If
    rs.Close
    End If
End Sub

Private Sub txtLoanee_GotFocus()
SelText txtLoanee
End Sub

'文件写库
Private Sub txtLoanee_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
    If Len(txtLoanee) > 0 Then
        If Not CheckListBoxDupe(lstColumn, txtLoanee) Then
            Set rs = db.OpenRecordset("ColumnList")
            With rs
                .AddNew
                !Columns = txtLoanee
                .Update
            End With
            rs.Close
            lstColumn.AddItem txtLoanee
            SelText txtLoanee
        Else
        MsgBox "输入的信息重复，重新输入。", 48, "操作提示"
        End If
    End If
End If
    
End Sub

'列表文件增减
Private Function CheckListBoxDupe(lst As ListBox, strList As String) As Boolean
Dim i As Integer
For i = 0 To lst.ListCount - 1
    If UCase(lst.List(i)) = UCase(strList) Then CheckListBoxDupe = True
    Next i
End Function

'字符串排列
Private Sub SelText(txtBox As TextBox)
txtBox.SelStart = 0
txtBox.SelLength = Len(txtBox)
End Sub