dbmodule.bas

饲料生产控制系统

Attribute VB_Name = "DBModule"
Option Explicit

Public adoCon As ADODB.Connection          ' DB楢愙
Private Const pDB_EXEC_TIMEOUT = 30         ' 楢愙帪娫
Public gstrConnecstr As String
'Public Const gstrConnecstr = "Provider=SQLOLEDB;Password=1;" & _
'                              "Persist Security Info=False;User ID=sa;" & _
'                              "Initial Catalog=hayashikane;" & _
'                              "Data Source=NO109\SQLEXPRESS"

'******************************************************************************
' 柤徧丂丂丂: gfConnect
' 婡擻丂丂丂: DB傊愙懕偡傞
' 嶲悢丂丂丂: 側偟
' 曉夞丂丂  : true      ----惉岟
'             false     ----幐攕
'******************************************************************************
Public Function gfConnect(ByVal isShowMsg As Boolean) As Boolean

On Error GoTo ErrgfConnectDB                 ' 僄儔乕偺応崌
    
    gfConnect = False
    
    '僨乕僞儀乕僗傊愙懕
    Set adoCon = New ADODB.Connection
    With adoCon
        .ConnectionString = gstrConnecstr
        .Mode = adModeReadWrite
        .CommandTimeout = pDB_EXEC_TIMEOUT
        .Open
    End With
    gfConnect = True

Resume_Err:
    Exit Function
    
ErrgfConnectDB:
    gfConnect = False
    Call gfDisConnect
    If isShowMsg = True Then
        Call MsgBox(ErrorMsg1, vbOKOnly + vbExclamation, FunErrorMsgTit_001)
    End If
    Resume Resume_Err
    
End Function

'******************************************************************************
' 柤徧丂丂丂: gfDisConnect
' 婡擻丂丂丂: DB傊偺愙懕傪愗傞
' 嶲悢丂丂丂: 側偟
' 曉夞丂丂  : 側偟
'******************************************************************************
Public Sub gfDisConnect()

    If adoCon.State = adStateOpen Then
        adoCon.Close
    End If
    Set adoCon = Nothing
    
End Sub

'******************************************************************************
' 柤徧丂丂丂: gfCreateRecordset
' 婡擻丂丂丂: 儗僐乕僪偺撉崬傒
' 嶲悢丂丂丂: strSQL      ---- SQL暥
'             rec         ---- Recordset
' 曉夞丂丂  : true        ----惉岟
'             false       ----幐攕
'******************************************************************************
Public Function gfCreateRecordset(ByVal strSql As String, _
                                  ByRef rec As ADODB.Recordset) As Boolean
    
On Error GoTo ErrgfCreateRecordset
    
    gfCreateRecordset = False
    
    '儗僐乕僪僙僢僩僆僽僕僃僋僩偺懚嵼傪敾抐
    If rec Is Nothing Then
        Exit Function
    End If
    
    '愙懕忬懺偺妋擣
    With rec
        .ActiveConnection = adoCon
        .LockType = adLockOptimistic
        .CursorType = adOpenDynamic
        .CursorLocation = adUseClient
        .Source = strSql
        .Open
    End With
    gfCreateRecordset = True
    
Resume_Err:
    Exit Function
    
ErrgfCreateRecordset:
    gfCreateRecordset = False
    Call MsgBox(ErrorMsg2, vbOKOnly + vbExclamation, FunErrorMsgTit_001)
    Resume Resume_Err
    
End Function

'******************************************************************************
' 柤徧丂丂丂: gfCreateRecordset
' 婡擻丂丂丂: 儗僐乕僪偺撉崬傒
' 嶲悢丂丂丂: strSQL      ---- SQL暥
'             rec         ---- Recordset
' 曉夞丂丂  : true        ----惉岟
'             false       ----幐攕
'******************************************************************************
Public Function gfView(ByVal strview As String, _
                                  ByRef rec As ADODB.Recordset) As Boolean
    
On Error GoTo ErrgfCreateRecordset

    
    gfView = False
    
    '儗僐乕僪僙僢僩僆僽僕僃僋僩偺懚嵼傪敾抐
    If rec Is Nothing Then
        Exit Function
    End If
    
    '愙懕忬懺偺妋擣
    With rec
        .ActiveConnection = adoCon
        .LockType = adLockBatchOptimistic
        .CursorType = adOpenDynamic
        .CursorLocation = adUseClient
        .Source = strview
        .Open
    End With
    gfView = True
    
Resume_Err:
    Exit Function
    
ErrgfCreateRecordset:
    gfView = False
    Call MsgBox(ErrorMsg2, vbOKOnly + vbExclamation, FunErrorMsgTit_001)
    Resume Resume_Err
    
End Function

'******************************************************************************
' 柤徧丂丂丂: gfCreateRecordset
' 婡擻丂丂丂: 儗僐乕僪偺撉崬傒
' 嶲悢丂丂丂: strSQL      ---- SQL暥
'             rec         ---- Recordset
' 曉夞丂丂  : true        ----惉岟
'             false       ----幐攕
'******************************************************************************
Public Function gfProCess(ByVal strProName As String, _
                          Optional ByVal pamName1 As String = vbNullString, _
                          Optional ByVal pam1 As String = vbNullString, _
                          Optional ByVal pamName2 As String = vbNullString, _
                          Optional ByVal pam2 As String = vbNullString, _
                          Optional ByVal pamName3 As String = vbNullString, _
                          Optional ByVal pam3 As String = vbNullString) As Recordset
    Dim strSql As String
    Dim adoCmd As New ADODB.Command
    Dim rtnRcd As New Recordset
    
On Error GoTo ErrgfCreateRecordset
    
    '愙懕忬懺偺妋擣
    If adoCon Is Nothing Or Not adoCon.State = adStateOpen Then
        MsgBox (ErrorMsg1)
        Exit Function
    End If
    
    'SQL暥偺幚峴
    With adoCmd
        Set .ActiveConnection = adoCon
        .CommandText = strProName
        .CommandType = adCmdStoredProc
        If Not pamName1 = vbNullString Then
            .Parameters(1) = pam1
        End If
        If Not pamName2 = vbNullString Then
            .Parameters(2) = pam2
        End If
        If Not pamName3 = vbNullString Then
            .Parameters(3) = pam3
        End If
        Set rtnRcd = .Execute
    End With
    If Not rtnRcd Is Nothing Then
        Set gfProCess = rtnRcd
    End If
    
Resume_Err:
    Exit Function
    
ErrgfCreateRecordset:
    Call MsgBox(ErrorMsg2, vbOKOnly + vbExclamation, FunErrorMsgTit_001)
    Resume Resume_Err
    
End Function

'******************************************************************************
' 柤徧丂丂丂: gfExecSQL
' 婡擻丂丂丂: 儗僐乕僪偺捛壛丄峏怴偲嶍彍
' 嶲悢丂丂丂: strSQL      ----SQL暥
' 曉夞丂丂  : true        ----惉岟
'             false       ----幐攕
'******************************************************************************
Public Function gfExecSQL(ByVal strSql As String) As Boolean
    
    Dim adoCmd As New ADODB.Command
    
On Error GoTo ErrCm_gfExecSQL
            
    gfExecSQL = False
    
    '愙懕忬懺偺妋擣
    If adoCon Is Nothing Or Not adoCon.State = adStateOpen Then
        MsgBox (ErrorMsg1)
        Exit Function
    End If
    
    'SQL暥偺幚峴
    With adoCmd
        .ActiveConnection = adoCon
        .CommandTimeout = pDB_EXEC_TIMEOUT
        .CommandText = strSql
        .Execute
    End With
    Set adoCmd = Nothing
    gfExecSQL = True
    
Resume_Err:
    Exit Function
    
ErrCm_gfExecSQL:
    gfExecSQL = False
    Set adoCmd = Nothing
    Call MsgBox(ErrorMsg3, vbOKOnly + vbExclamation, FunErrorMsgTit_001)
    Resume Resume_Err

End Function

'******************************************************************************
' 柤徧丂丂丂: gfExecTrans
' 婡擻丂丂丂: 儗僐乕僪偺捛壛丄峏怴偲嶍彍
' 嶲悢丂丂丂: strSQL丗SQL暥
' 曉夞丂丂  : TRUE:惉岟丂丂FALSE丗幐攕
' 婡擻奣梫丂:
'******************************************************************************
Public Function gfExecTrans(ByVal strSql As String) As Boolean

    Dim adoCmd As New ADODB.Command
    
On Error GoTo ErrCm_gfExecSQL
            
    gfExecTrans = False
    
    '愙懕忬懺偺妋擣
    If adoCon Is Nothing Or Not adoCon.State = adStateOpen Then
        MsgBox (ErrorMsg1)
        Exit Function
    End If
    
    '僩儔儞僓僋僔儑儞奐巒
    adoCon.BeginTrans
        
    'SQL暥偺幚峴
    With adoCmd
        .ActiveConnection = adoCon
        .CommandTimeout = pDB_EXEC_TIMEOUT
        .CommandText = strSql
        .Execute
    End With
    
    '僐儈僢僩
    adoCon.CommitTrans
    Set adoCmd = Nothing
    gfExecTrans = True
    
Resume_Err:
    Exit Function
    
ErrCm_gfExecSQL:
    gfExecTrans = False
    '儘乕儖僶僢僋
    adoCon.RollbackTrans
    Set adoCmd = Nothing
    Call MsgBox(ErrorMsg3, vbOKOnly + vbExclamation, FunErrorMsgTit_001)
    Resume Resume_Err
    
End Function

'******************************************************************************
' 柤徧丂丂丂: BackupDB
' 婡擻丂丂丂: 僨乕僞儀乕僗傪僶僢僋傾僢僾
' 嶲悢丂丂丂: strSQL      ----SQL暥
' 曉夞丂丂  : true        ----惉岟
'             false       ----幐攕
'******************************************************************************
Public Function BackupDB() As Boolean
    Dim strSql As String
    Dim backName As String
    Dim backUrl1 As String
    Dim backUrl2 As String
    
On Error GoTo ErrCm_gfExecSQL
            
    BackupDB = False
'    Call ReadMainBack(backUrl1, backUrl2)
    backUrl1 = gDBINITPATH
    backUrl2 = gDBFILEHEAD
    
    backName = backUrl1 & backUrl2 & ".bak"
    strSql = "backup database [" & gDBNAME & "] to disk='" & backName & "' With init,SKIP"
    
    '愙懕忬懺偺妋擣
    If adoCon Is Nothing Then
        MsgBox (ErrorMsg1)
        Exit Function
    End If
    
    If Not adoCon.State = adStateOpen Then
        MsgBox (ErrorMsg1)
        Exit Function
    End If
    
    adoCon.Execute (strSql)
    
    BackupDB = True
    
Resume_Err:
    Exit Function
    
ErrCm_gfExecSQL:
    BackupDB = False
    Resume Resume_Err

End Function

'******************************************************************************
' 柤徧丂丂丂: ResertDB
' 婡擻丂丂丂: 僨乕僞儀乕僗傪暅尦
' 嶲悢丂丂丂: strSQL      ----SQL暥
' 曉夞丂丂  : true        ----惉岟
'             false       ----幐攕
'******************************************************************************
Public Function ResertDB(ByVal url As String) As Boolean
    Dim sn As New ADODB.Recordset
    Dim cn As New ADODB.Connection
    Dim strUrl1 As String
    Dim strUrl2 As String
    Dim strUrl3 As String
   
On Error GoTo ErrCm_gfExecSQL
            
    ResertDB = False
    
'    Call ReadMainResert(strUrl1, strUrl2, strUrl3)
    strUrl1 = gDBINITPATH
    strUrl2 = gDBNAME
    strUrl3 = gRESTORE_CON

    cn.Open strUrl3
    
    sn.Open "select spid from sysprocesses where dbid=db_id('" & strUrl2 & "')", cn

    Do While Not sn.EOF
        cn.Execute "kill " & sn("spid")
        sn.MoveNext
    Loop
    sn.Close
  
    cn.Execute ("RESTORE DATABASE " & strUrl2 & " FROM  DISK = '" & strUrl1 & strUrl2 & ".bak' with recovery,REPLACE")
    
    cn.Close
    
    Set cn = Nothing
    
    Call gfConnect(True)
   
    ResertDB = True
    
Resume_Err:
    Exit Function
    
ErrCm_gfExecSQL:
    ResertDB = False
    Resume Resume_Err

End Function