moddatabase.bas

ERP管理系统源代码erp 管理系统源代码

'           BACKUP DATABASE CYCRM TO CYCRM_BACK -- WITH STATS = 1
'           EXEC sp_dropdevice 'CYCRM_BACK'  , 'DELFILE'
'           调用 SPEX_DBBC_BACKUP 增加一条记录
' 数据库权限：调用 SQL 系统存储过程时需要一定权限。
'           sp_addumpdevice 要求操作员必须是 diskadman
'           sp_dropdevice   要求操作员必须是 sysadman
Public Function BackupDataBase(ByVal strFileName As String, ByVal fFull As Boolean) As Boolean
    On Error GoTo ERROR_EXIT
    Dim strDevice As String
    Dim cmd As New ADODB.Command, rs As New ADODB.Recordset
    Dim fDeviceAdded As Boolean, str As String
    
    strDevice = CreateDBDevice(dbMyDB, strFileName, "CYCRM_BACKUP_")
    str = GetUserName
    With cmd
        Set .ActiveConnection = dbMyDB
        .CommandType = adCmdText
        .CommandText = " BACKUP DATABASE " & g_MyUserDB.strUserDatabase & _
                        " TO " & strDevice & " WITH INIT "
        If Not fFull Then .CommandText = .CommandText & " WITH DIFFERENTIAL "
        .Execute
    End With
    
    Set cmd = Nothing
    Set cmd = New ADODB.Command
    If rs.State = adStateOpen Then rs.Close
    Set cmd.ActiveConnection = dbMyDB
    cmd.CommandType = adCmdText
    cmd.CommandText = "SELECT * FROM T_DATABASE_BACKUP WHERE bc_filename = '" & strFileName & "'"
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenDynamic, adLockOptimistic
    If rs.EOF Or rs.RecordCount <> 1 Then
        rs.AddNew
    End If
    
    '修改BOM表基本信息
    If Trim(strFileName) <> "" Then rs!bc_filename = strFileName
    If Trim(g_MyUserDB.strUserDatabase) <> "" Then rs!bc_SrcdbName = g_MyUserDB.strUserDatabase
    rs!bc_BackupTime = Date & Time
    If Trim(fFull) <> "" Then rs!bc_full = IIf(fFull, 0, 1)
    If Trim(str) <> "" Then rs!bc_UserName = str
    rs!bc_flag = 1
    rs.Update
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    DropDBDevice dbMyDB, strDevice
    BackupDataBase = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDatabase"
    m_tagErrInfo.strErrFunc = "BackupDataBase"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
ERROR_EXIT1:
    DropDBDevice dbMyDB, strDevice
    Set cmd = Nothing
    BackupDataBase = False
End Function

'***********************************************
' 删除数据库备份文件操作
Public Sub DeleteBackupFile(ByVal strFileName As String)
    On Error Resume Next
    Dim strDevice As String
    Dim cmd As New ADODB.Command
    
    If Trim(strFileName) = "" Then Exit Sub
    strDevice = CreateDBDevice(dbMyDB, strFileName, "CYCRM_DELETE_")
    DropDBDevice dbMyDB, strDevice, True
    '删除数据库记录
    With cmd
        Set .ActiveConnection = dbMyDB
        .CommandType = adCmdStoredProc
        .CommandText = "SPEX_DBBC_DELETE_FILE"
        .Parameters.Append .CreateParameter("RETURN_VALUE", adInteger, adParamReturnValue, , Null)
        .Parameters.Append .CreateParameter("bc_filename", adVarChar, adParamInput, 255, Trim(strFileName))
        .Execute
        If CLng(.Parameters("RETURN_VALUE").Value) <> 0 Then
            m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
            m_tagErrInfo.strErrFile = "modDatabase"
            m_tagErrInfo.strErrFunc = "DeleteBackupFile"
            m_tagErrInfo.nErrNum = -1
            m_tagErrInfo.strErrDesc = "调用存储过程 SPEX_DBBC_DELETE_FILE 出错，返回值 " _
                & .Parameters("RETURN_VALUE").Value
            If Err.Number <> 0 Then Err.Clear
            modErrorInfo.WriteErrLog m_tagErrInfo
        End If
        
    End With
    Set cmd = Nothing
End Sub

'***********************************************
' 在数据库中创建设备
' 参数：    strFileName     文件路径
'           strPrefix       设备名的前导字符串
' 返回值：如果成功则返回设备名，否则返回空字符串
' 数据库权限：调用 SQL 系统存储过程时需要一定权限。
'           sp_addumpdevice 要求操作员必须是 diskadman
'           sp_dropdevice   要求操作员必须是 sysadman
Private Function CreateDBDevice(ByVal conn As ADODB.Connection, _
                                ByVal strFileName As String, _
                                Optional ByVal strPrefix As String = "") As String
    On Error GoTo ERROR_EXIT
    Dim strDevice As String
    Dim cmd As New ADODB.Command
    
RESTART:
    Randomize Second(Time)
    strDevice = strPrefix & CStr(CLng(Rnd * 10000000))
    
    With cmd
        Set .ActiveConnection = conn
        .CommandType = adCmdStoredProc
        .CommandText = "sp_addumpdevice"
        .Parameters.Append .CreateParameter("RETURN_VALUE", adInteger, adParamReturnValue, , Null)
        .Parameters.Append .CreateParameter("devtype", adVarChar, adParamInput, 20, "disk")
        .Parameters.Append .CreateParameter("logicalname", adVarChar, adParamInput, 64, strDevice)
        .Parameters.Append .CreateParameter("physicalname", adVarChar, adParamInput, 260, strFileName)
        .Execute
        If CLng(.Parameters("RETURN_VALUE").Value) <> 0 Then GoTo ERROR_EXIT
    End With
    
    CreateDBDevice = strDevice
    Set cmd = Nothing
    Exit Function
ERROR_EXIT:
    If Err.Number <> 0 Then
        MsgBox Error(Err.Number), vbOKOnly Or vbExclamation, "数据库错误"
        If Err.Number = -2147217900 Then
            If vbYes = MsgBox("必须删除该设备才能进行后续操作，是否删除该设备？", vbYesNo, "操作提示") Then
                Dim strDev As String
                strDev = GetDBDevice(conn, strFileName)
                If strDev <> "" Then
                    DropDBDevice conn, strDev
                    GoTo RESTART
                Else
                    MsgBox "删除该设备失败", vbOKOnly Or vbExclamation, "数据库错误"
                End If
            End If
        End If
        Err.Clear
    End If
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDatabase"
    m_tagErrInfo.strErrFunc = "BackupDataBase"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    Set cmd = Nothing
    CreateDBDevice = ""
End Function

'***********************************************
' 在数据库中获得设备名称
' 参数：    strPhysicalName 设备的物理名称
' 返回值：如果成功则返回设备名，否则返回空字符串
' 数据库权限：调用 SQL 系统存储过程时需要一定权限。
'           sp_addumpdevice 要求操作员必须是 diskadman
'           sp_dropdevice   要求操作员必须是 sysadman
Private Function GetDBDevice(ByVal conn As ADODB.Connection, ByVal strPhysicalName As String) As String
    On Error GoTo ERROR_EXIT
    Dim cmd As New ADODB.Command
    Dim rs As New ADODB.Recordset
    Dim strDevice As String
    
    strDevice = ""
    With cmd
        Set .ActiveConnection = conn
        .CommandType = adCmdText
        .CommandText = "sp_helpdevice"
        Set rs = .Execute
        While Not rs.EOF
            If Trim(rs!physical_name) = Trim(strPhysicalName) Then strDevice = Trim(rs!device_name)
            rs.MoveNext
        Wend
    End With
    If strDevice = "" Then GoTo ERROR_EXIT
    
    Set cmd = Nothing
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    GetDBDevice = strDevice
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDatabase"
    m_tagErrInfo.strErrFunc = "BackupDataBase"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    Set cmd = Nothing
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    GetDBDevice = ""
End Function

'***********************************************
' 在数据库中删除设备
' 参数：    strDeviceName 设备名
' 数据库权限：调用 SQL 系统存储过程时需要一定权限。
'           sp_dropdevice   要求操作员必须是 sysadman
Private Sub DropDBDevice(ByVal conn As ADODB.Connection, _
                         ByVal strDeviceName As String, _
                         Optional ByVal fDelfile As Boolean = False)
    On Error GoTo ERROR_EXIT
    Dim cmd As New ADODB.Command
    
    If strDeviceName = "" Then Exit Sub
    With cmd
        Set .ActiveConnection = conn
        .CommandType = adCmdText
        .CommandText = "sp_dropdevice " & strDeviceName
        If fDelfile Then .CommandText = .CommandText & " , delfile "
        .Execute
    End With
    
    Set cmd = Nothing
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDatabase"
    m_tagErrInfo.strErrFunc = "BackupDataBase"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    Set cmd = Nothing
End Sub

'***********************************************
' 初始化可供导入导出的数据库表信息
' 窗体 dlgDataExport 和 dlgDataImport 要用到此函数
Public Function InitBKTableInfo() As Boolean
    On Error GoTo ERROR_EXIT
    Dim strTables() As String
    Dim strTemp() As String
    Dim i  As Long
    
'    strTables = Split(m_strTableDescList, "##")
    ReDim g_BKTableSet(UBound(strTables))
    For i = LBound(strTables) To UBound(strTables)
        strTemp = Split(strTables(i), vbTab)
        g_BKTableSet(i).strTableDesc = Trim(strTemp(0))
        g_BKTableSet(i).strTableName = Trim(strTemp(1))
    Next
    InitBKTableInfo = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDatabase"
    m_tagErrInfo.strErrFunc = "BackupDataBase"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    InitBKTableInfo = False
End Function

'***********************************************
' 获得数据库当前连接的用户数目
' 使用 SQL 的 sp_who 存储过程
Private Function GetDBConnectionUserNum(ByVal dbConn As ADODB.Connection) As Long
    On Error GoTo ERROR_EXIT
    Dim cmd As New ADODB.Command
    Dim rs As New ADODB.Recordset
    Dim nUser As Long