mdlappenddatabase.bas

本系统可用于医院和专业体检中心的健康体检管理

Attribute VB_Name = "mdlAppendDatabase"
Option Explicit
Public gstrCurrPath As String
Public Const DatabaseName = "DHTJ"    '数据库名
Public Const DatabaseDir = "Data\"     '数据存放路径
Public GCon As ADODB.Connection '全局连接变量

Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long


'**************************************************************
'☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆
'★★★★★★★★★★★★★★            ★★★★★★★★★★★★★★
'★★★★★★★★★★★★★★   主函数   ★★★★★★★★★★★★★★
'★★★★★★★★★★★★★★            ★★★★★★★★★★★★★★
'☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆
'**************************************************************
Public Sub Main()
On Error Resume Next
    Dim strConString As String
    
    '设置当前路径
    SetCurrPath
    
    '首先尝试连接数据库
    strConString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=master;Server=(Local)"
    Set GCon = New ADODB.Connection
    GCon.ConnectionString = strConString
    GCon.Open
    If Err.Number <> 0 Then
        Err.Clear
        '如果连接不成功，
        '打开连接对话框，让用户设置连接参数
        dlgServer_A.Show vbModal
        Unload dlgServer_A
        Set dlgServer_A = Nothing
    Else
        '尝试连接成功
        '附加数据库
        AppendDatabase
    End If
    
    TerminateProcess GetCurrentProcess, 0
End Sub

'设置应用程序的当前路径：含斜杠“\”
Public Sub SetCurrPath()
On Error Resume Next
    If Right(App.Path, 1) <> "\" Then
        gstrCurrPath = App.Path & "\"
    Else
        gstrCurrPath = App.Path
    End If
End Sub

'附加数据库
Public Function AppendDatabase() As Boolean
On Error GoTo ErrMsg
    Dim rsTemp As ADODB.Recordset
    Dim strSQL As String
    Dim strDataFile As String
    Dim strLogFile As String
    
    Screen.MousePointer = 11
    AppendDatabase = False
    
    strSQL = "select Count(*) from sysdatabases" _
            & " where name='" & DatabaseName & "'"
    Set rsTemp = New ADODB.Recordset
    rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsTemp(0) < 1 Then '第一次运行
        '首先检查数据文件是否存在
        strDataFile = gstrCurrPath & DatabaseDir & DatabaseName & ".mdf"
        If Dir(strDataFile) = "" Then
            '数据文件不存在
            MsgBox "数据库文件不存在！请联系销售商！", vbExclamation, "提示"
            GoTo ExitLab
        End If
        
        '其次检查日志文件是否存在
        strLogFile = gstrCurrPath & DatabaseDir & DatabaseName & "_log.ldf"
        If Dir(strLogFile) = "" Then
            '日志文件不存在
            MsgBox "数据库备份文件不存在！请联系销售商！", vbExclamation, "提示"
            GoTo ExitLab
        End If
        
        '通过代码附加数据库
        strSQL = "sp_attach_db @dbname=N'" & DatabaseName & "'," _
                & "@filename1='" & strDataFile & "'," _
                & "@filename2='" & strLogFile & "'"
        GCon.Execute strSQL
'        '添加到日志
'        AddLog "第一次运行", "成功附加数据库！", OperationLog
        MsgBox "数据库安装成功！", vbInformation, "提示"
    Else
        MsgBox "数据库已经在运行！", vbInformation, "提示"
    End If
    GCon.Close
    Set GCon = Nothing
    
    AppendDatabase = True
    
    GoTo ExitLab
ErrMsg:
    MsgBox "数据库安装失败！请检查Microsoft SQL Server的配置是否正确！", vbExclamation, "提示"
ExitLab:
    Screen.MousePointer = 0
End Function

'局域网里搜索SQL服务器
'可以列出局域网内注册或未注册的SQL服务器
'参数：用于显示服务器名的组合框
Public Function GetLocalSQLServer(ByRef cmbServer As ComboBox) As Boolean
    Dim oSQLServerDMOApp   As SQLDMO.Application
    Dim oServerGroup   As SQLDMO.ServerGroup
    Dim oRegisteredServer   As SQLDMO.RegisteredServer
    Dim i   As Integer, j   As Integer
    Dim namX   As NameList
    Dim blnEquate As Boolean
    
    Screen.MousePointer = 11
    
    Set oSQLServerDMOApp = New SQLDMO.Application
    
    cmbServer.Clear
    '首先显示的是注册了的数据库
    '处理所有服务器组
    For Each oServerGroup In oSQLServerDMOApp.ServerGroups
        '处理每个注册了的服务器
        For Each oRegisteredServer In oServerGroup.RegisteredServers
            '添加每个名字到  combobox
            cmbServer.AddItem oRegisteredServer.Name
        Next
    Next
    Set oRegisteredServer = Nothing
    Set oServerGroup = Nothing

    '接下来显示尚未注册的数据库
    Set namX = oSQLServerDMOApp.ListAvailableSQLServers
    For i = 1 To namX.Count
        blnEquate = False
        '检查该服务器是否已经被列出来
        For j = 0 To cmbServer.ListCount - 1
            If cmbServer.List(j) = namX.Item(i) Then
                blnEquate = True
                Exit For '退出内圈循环
            End If
        Next j
        If blnEquate = False Then
            cmbServer.AddItem namX.Item(i)
        End If
    Next i
    
    '显示第一个服务器
    If cmbServer.ListCount > 0 Then
        cmbServer.ListIndex = 0
    End If
    
    Set namX = Nothing
    Set oSQLServerDMOApp = Nothing
    
    Screen.MousePointer = 0
End Function

'创建一个标准执行模块，命名modErrorMsg，用于显示出错信息：
Public Sub ErrMsg(Status)
'The Status parameter should be passed as a variant array
'of 3 elements as listed"
' 0-Error Number
' 1-Error Description
' 2-Error Source

    'define local variables
    Dim strErr As String
    
    'Build the error information
    strErr = "Error " & Trim(Str(Status(0))) & " In " & Status(2) & ":" & vbCrLf & Status(1)
    
    'display the error information
'    AddLog Status(0), Status(1), ErrorLog, Status(2)
'    If gblnAuto = False Then
        MsgBox strErr, vbInformation, "提示"
'    Else
'        ShowDialog strErr
'    End If
End Sub

Public Function SetError(ErrNumber As Long, ErrDescription As String, ErrSource As String)
'This function will return a variant array of three elements
'set to the passed parameters
    'Define local ErrorType
    Dim pError(2)
 
    'Assign error
    pError(0) = ErrNumber
    pError(1) = ErrDescription
    pError(2) = ErrSource
   
    'Return the ErrorType
    SetError = pError
End Function