main.frm

来自「这个是我以前做的一个客户管理系统.包内已经含有源码和所用到的控件.代码是用VB写」· FRM 代码 · 共 298 行

VERSION 5.00
Begin VB.Form main 
   Appearance      =   0  'Flat
   BackColor       =   &H80000005&
   BorderStyle     =   4  'Fixed ToolWindow
   Caption         =   "国信客户档案管理系统-----系统初始化"
   ClientHeight    =   1035
   ClientLeft      =   45
   ClientTop       =   270
   ClientWidth     =   7365
   Icon            =   "main.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1035
   ScaleWidth      =   7365
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.Timer Timer1 
      Left            =   3570
      Top             =   0
   End
   Begin VB.Image Image1 
      Height          =   480
      Left            =   180
      Picture         =   "main.frx":030B
      Top             =   240
      Width           =   480
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "正在初始化系统，大概需要2-3分钟，请稍等..."
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   -1  'True
         Strikethrough   =   0   'False
      EndProperty
      Height          =   285
      Left            =   900
      TabIndex        =   0
      Top             =   360
      Width           =   6030
   End
End
Attribute VB_Name = "main"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim mbActive        As Boolean

Private Function mbCreateSysDB() As Boolean
'************************************************
'
'Purpsoe:
'       Create Database Qinyin
'
'*****************************************

    On Error GoTo ErrCreate
    Screen.MousePointer = vbDefault
    Cn.BeginTrans
    Cn.Execute "Use master"
    Cn.Execute "Create Database " & strSysDBName
'    Cn.Execute "Use " & strSysDBName
    Cn.CommitTrans
    Screen.MousePointer = vbDefault
    mbCreateSysDB = True
    Exit Function
ErrCreate:
    mbCreateSysDB = False
    Cn.RollbackTrans
    Screen.MousePointer = vbDefault
'    gShowMsg Me.Caption & vbCrLf & " 创建系统数据库错误 bCreateSysDB"
    
End Function

Private Function bExistDataBase() As Boolean
'**********************************************
'
'Purpose:
'       是否已经存在数据库QinYin和是否重建QinYin数据库
'
'**********************************************

    Dim sSQL        As String
    Dim RS          As New ADODB.Recordset
    Dim bTmp        As Boolean
    Dim sDBName     As String
    Dim lResult     As Integer
    
    On Error GoTo errSQLExistDatabase
    sDBName = "Archives"
    
    sSQL = "select CntDB = count(*)"
    sSQL = sSQL & " From master.dbo.sysdatabases"
    sSQL = sSQL & " Where name = '" & sDBName & "'"
    
    Screen.MousePointer = vbHourglass
    RS.Open sSQL, Cn
    Screen.MousePointer = vbDefault
    
    If RS!CntDB = 0 Then
        bTmp = False
    Else
        bTmp = True
    End If
    RS.Close
    
    bExistDataBase = bTmp
    If bExistDataBase Then
        lResult = MsgBox("数据库已经存在,若要重新建立将会把所有的数据清除掉！" & vbCrLf & vbCrLf & "是否重新建立??", vbQuestion + vbYesNo, Me.Caption)
        If lResult = vbYes Then bExistDataBase = bDelSysData
    End If
    Exit Function
errSQLExistDatabase:
    Screen.MousePointer = vbDefault
    bExistDataBase = False
    Exit Function
End Function
Private Function bDelSysData() As Boolean
    
    Dim sDb         As String
    Dim bBegin      As Boolean
    
    On Error GoTo ErrDelSysData
    
    '判断数据库是否在使用
    sDb = SQLGetCurrentDatabaseName(Cn)
    If sDb = strSysDBName Then
        MsgBox "系统数据库库正在被使用，请关闭" & strSysDBName & "数据库。" & vbCrLf & " 然后再进行系统初始化。", vbInformation, "提示"
        bDelSysData = False
        Exit Function
    End If
        
    '备份原数据库内容
    Screen.MousePointer = vbHourglass
    Cn.BeginTrans
    bBegin = True
    Cn.Execute "Backup Database Archives to disk ='" & App.Path & "\OldArchives.dat'"
    Cn.Execute "Use master"
    Cn.Execute "DROP DATABASE " & strSysDBName
    Cn.CommitTrans
    bDelSysData = False
    Screen.MousePointer = vbDefault
    Exit Function
ErrDelSysData:
    Screen.MousePointer = vbDefault
    If bBegin Then Cn.RollbackTrans
    bDelSysData = False
    gShowMsg "删除数据库错误: "
End Function
Private Function mbInsertInitData() As Boolean
'****************************************
    
    Dim FilePath            As String
    Dim sSQL                As String
    
    On Error GoTo ErrInitData
    
    FilePath = App.Path & "\lib\Archives.dat"
    If Not ExistFile(FilePath) Then
        MsgBox "系统文件{" & FilePath & "}不存在,不能初始化！"
        mbInsertInitData = False
        Exit Function
    End If
    
    '判断是否有老数据文件存在
    FilePath = App.Path & "\lib\Archives_data.mdf"
    If ExistFile(FilePath) Then Kill FilePath
    FilePath = App.Path & "\lib\Archives_log.ldf"
    If ExistFile(FilePath) Then Kill FilePath
    
    '生成数据库
    FilePath = App.Path & "\lib\Archives.dat"
    sSQL = "Use Master"
    sSQL = sSQL & vbCrLf & "Restore database Archives from disk = '" & FilePath & "'"
    sSQL = sSQL & vbCrLf & " WITH RECOVERY,"
    sSQL = sSQL & vbCrLf & " Move  'Archives_data' TO '" & App.Path & "\lib\Archives_data.mdf',"
    sSQL = sSQL & vbCrLf & " Move  'Archives_log' TO '" & App.Path & "\lib\Archives_log.ldf'"
    Screen.MousePointer = vbHourglass
    Cn.Execute sSQL
    Screen.MousePointer = vbDefault
    
    '测试生成的数据库
    Screen.MousePointer = vbHourglass
    Cn.Execute "Use " & strSysDBName
    Screen.MousePointer = vbDefault
    
    mbInsertInitData = True
    Exit Function
ErrInitData:
    Screen.MousePointer = vbDefault
    mbInsertInitData = False
    gShowMsg "初始化系统出错"
    
End Function

Private Function mbCreateLoginID() As Boolean

Dim sSQL As String
Dim sDb As String
Dim sVer As String
    
    On Error GoTo ErrmbCreateLoginID
    
    Screen.MousePointer = vbHourglass
    sDb = SQLGetCurrentDatabaseName(Cn)
    
    Cn.Execute "use master"
    
    If saPassword = "" Then
        '若为空，则用NULL值代替
        sSQL = "Exec sp_password NULL" & ",'Gxliao','sa'"
    Else
        sSQL = "Exec sp_password '" & saPassword & "','Gxliao','sa'"
    End If
    
    Cn.Execute sSQL
    Screen.MousePointer = vbDefault
    
    mbCreateLoginID = True
    
    Exit Function
    
ErrmbCreateLoginID:
    Screen.MousePointer = vbDefault
    mbCreateLoginID = False
    MsgBox "创建系统内部用户时出错。" & vbCrLf & "代号：" & Err & vbCrLf & Error, vbInformation, Me.Caption
    Exit Function
End Function

Private Function mbInitSys() As Boolean

    '是否已经存在数据库了

    If bExistDataBase() Then mbInitSys = False: Exit Function
    
'    '创建系统数据库
'    If Not mbCreateSysDB() Then mbInitSys = False: Exit Function
    
    '创建表和生成初始数据
    If Not mbInsertInitData Then
        Cn.Execute "Restore database Archives from disk = '" & App.Path & "\OldArchives.dat'"
        mbInitSys = False
        Exit Function
    End If
    
    '创建LoginID
    If Not mbCreateLoginID() Then mbInitSys = False: Exit Function
    mbInitSys = True

End Function
Private Sub Form_Activate()
    
    If mbActive Then
        mbActive = False
        Timer1.Enabled = True
        
'        If mbInitSys Then
'            Unload Me
'            MsgBox "成功完成系统初始化", vbInformation + vbOKOnly, "系统初始化"
'        Else
'            Unload Me
'            MsgBox "系统初始化错误，请检查原因，再进行初始化工作", vbQuestion + vbOKOnly, "系统初始化"
'        End If
    End If
    
    
End Sub

Private Sub Form_Load()
'    center Me
 
    mbActive = True
    Timer1.Enabled = False
    Timer1.Interval = 100
'    ProBar.Visible = False
End Sub

Private Sub Timer1_Timer()
    Timer1.Enabled = False
    If mbInitSys Then
        Unload Me
        MsgBox "成功完成系统初始化", vbInformation + vbOKOnly, "系统初始化"
    Else
        Unload Me
        MsgBox "系统初始化错误，请检查原因，再进行初始化工作", vbQuestion + vbOKOnly, "系统初始化"
    End If

End Sub