mdlmain.bas

自己写的

Attribute VB_Name = "mdlMain"
Option Explicit

Public cn As ADODB.Connection
Public rs As ADODB.Recordset


Public Sub Main()

    If App.PrevInstance Then                                '只允许运行一个实例
        MsgBox "本系统正在运行中！", vbOKOnly
        Exit Sub
    End If
    
    frmConnect.Show



End Sub



'连接数据库
Public Function ConnectDB(DBServer As String, DBUserID As String, DBPassword As String) As Boolean
    On Error GoTo err
    
    Set cn = New ADODB.Connection
    With cn
        .ConnectionString = "Provider=SQLOLEDB.1;Password=" & DBPassword & ";Persist Security Info=True;User ID=" & DBUserID & ";Initial Catalog=master;Data Source=" & DBServer
        .Mode = adModeReadWrite
        .CursorLocation = adUseServer
        .ConnectionTimeout = 5
        .CommandTimeout = 5
        .Open
    End With
    
    Set rs = New ADODB.Recordset
    With rs
        .CursorLocation = adUseServer
        .CursorType = adOpenForwardOnly
        .LockType = adLockOptimistic
        .ActiveConnection = cn
    End With
        
    ConnectDB = True
    Exit Function
err:
    ConnectDB = False
    MsgBox err.Description
End Function



'备份数据库
Public Function BackUpDataBase(ByVal sBackUpFilePath As String, ByVal sDataBaseName As String) As Boolean
    On Error GoTo err
        
    Dim sFileName As String
    sFileName = sDataBaseName & "(" & Format(CStr(Now()), "yy-mm-dd hh.mm") & ").备份文件"
    If Right(sBackUpFilePath, 1) <> "\" Then
        sBackUpFilePath = sBackUpFilePath & "\"
    End If
    sFileName = sBackUpFilePath & sFileName
    
    Dim SQLTemp As String
    SQLTemp = "backup database [" & sDataBaseName & "]" & vbCrLf & _
            "to disk='" & sFileName & "'" & vbCrLf & _
            "with  name=N'" & sDataBaseName & "'," & vbCrLf & _
            "description='完全备份',init,format,skip,restart"
       
    cn.Execute SQLTemp
          
    
    BackUpDataBase = True
    Exit Function
err:
    BackUpDataBase = False
    MsgBox err.Description
End Function