clsdatabase.cls

企业ERP系统 采用VB+SQL2000实现。 有客户合约

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsDatabase"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'数据对象
'主获取数据连结的相关操作

Private Type dataInf
    userID As String
    passWord As String
    dataBase As String
    serverName As String
    enterMode As Boolean    '接入方式，true本地接入,false远端接入
    address1 As String
    address2 As String
    port As String
End Type
Private data As dataInf

'打开ini文件
Public Function OpenIni(bUpdate As Boolean) As Boolean
'bUpdate=false,是读入配置信息
'bUpdate=true,是写入配置信息
    Dim strSql As String
    Dim rs As adodb.Recordset
    Dim cnIni As adodb.Connection  '连接对象
    Dim strConnect As String
   ' strConnect = "Driver={Microsoft Access Driver (*.mdb)};uid=;pwd=;dbq=" & App.Path & "\config.mdb"
   strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\config.ini;Persist Security Info=False;Jet OLEDB:Database password=NjEuMTQ1LjEzNS4yMQNjEuMTQ1LjEzNS4yMQ"

    On Error GoTo errHandle
    Set cnIni = New adodb.Connection
    With cnIni
        .CursorLocation = adUseClient
        .ConnectionTimeout = 60
    End With
    
    cnIni.Open strConnect
    
    If bUpdate = False Then
        Set rs = New adodb.Recordset
        With rs
          .CursorLocation = adUseClient
          .CursorType = adOpenDynamic
          .LockType = adLockOptimistic
          Set .ActiveConnection = cnIni
        End With
        rs.Open "select * from config"
        
        If (rs.RecordCount > 0) Then
            
            data.serverName = rs!serverName
            data.dataBase = rs!txtDatabase
            data.userID = rs!userID
            data.passWord = rs!txtPassword
            data.enterMode = rs!enterMode
            data.address1 = rs!address1
            data.address2 = rs!address2
            On Error GoTo errAddPort
            data.port = Trim$(NullValue(rs.Fields!port))
        End If
        rs.Close
        Set rs = Nothing
    Else '更新配置文件
        strSql = "update config set EnterMode=" & data.enterMode & ",Address1='" & data.address1 & "',Address2='" & _
        data.address2 & "',ServerName='" & data.serverName & "',txtdatabase='" & data.dataBase & "',userid='" & data.userID & _
        " ',txtPassword='" & data.passWord & "',port='" & data.port & "'"
        
        cnIni.Execute strSql
    End If
    cnIni.Close
    Set cnIni = Nothing
    OpenIni = True
    Exit Function
errHandle:

    OpenIni = False
    MsgBox "打开配置文件错误！", vbExclamation, "提示"
errAddPort:
    
    rs.Close
    rs.Open "ALTER TABLE Config ADD Port char(50)  null"
    cnIni.Execute "update config set port='717'"
    data.port = 717
'    rs.Close
    Set rs = Nothing
    cnIni.Close
    Set cnIni = Nothing
    OpenIni = True
End Function

'打开数据库
Public Function OpenData() As Boolean

''如果当前数据库对象是打开的，那么先关闭，再打开
    CloseData
    If GetEnterMode = False Then
        objDatabase.NewServerName
    End If
    Dim strConnect As String
    Dim strServerName As String
    strServerName = objDatabase.GetServerName
    If data.port = "1433" Or data.port = "" Then
        strServerName = strServerName
    Else
        strServerName = strServerName & "," & data.port
    End If
    strConnect = "Provider=SQLOLEDB.1;Persist Security Info=True;User ID=" & objDatabase.GetUserID & ";Password=" & objDatabase.GetPassword & _
     ";Data Source=" & strServerName & ";Initial Catalog=" & objDatabase.GetDatabase
     'MsgBox strConnect
    On Error GoTo errHandle
    
    With cn
        .CursorLocation = adUseClient
        .ConnectionTimeout = 30
    End With
    cn.Open strConnect
    
    OpenData = True
    Exit Function
errHandle:
    OpenData = False
End Function
'对象初始化
Private Sub Class_Initialize()
    Set cn = New adodb.Connection
End Sub
'执行SQL语句
Public Function ExecCmd(pStrSql As String) As Boolean
   Dim cmd As adodb.Command
   Set cmd = New adodb.Command
   On Error GoTo errHandle
   With cmd
       .CommandType = adCmdText
       .CommandTimeout = 60
       .CommandText = pStrSql
       Set .ActiveConnection = cn
   End With
   cmd.Execute
   Set cmd = Nothing
   ExecCmd = True
   Exit Function
errHandle:
   Set cmd = Nothing
   DatabaseError
End Function
'关闭数据库对象
Public Sub CloseData()
    ''如果是打开的先关闭数据库
    If cn.State = 1 Then
        cn.Close
        'Set cn = Nothing
    End If
End Sub
'格式货SQL语名
Public Function FormatSQL(strSql As Variant) As Variant
    If Not IsNull(strSql) Then
        FormatSQL = "'" & Trim$(strSql) & "'"
    End If
End Function
'格式化模糊查询SQL语名
Public Function FormatLikeSQL(strSql As Variant) As Variant
    FormatLikeSQL = " like '%" & Trim$(strSql) & "%'"
End Function
'设置新地址
Public Sub NewServerName()
    ''重新去互联网获取当前的地址
    ''赋值将当前对象地址
    data.serverName = ReadServerName
End Sub
'获取用户名
Public Function GetUserID() As String
    GetUserID = Trim$(data.userID)
End Function
'设置用户名
Public Sub SetUserID(curValue As String)
    data.userID = curValue
End Sub
'获取密码
Public Function GetPassword() As String
    GetPassword = DeCode(data.passWord)
End Function
'设置密码
Public Sub SetPassword(curValue As String)
    data.passWord = EnCode(curValue)
End Sub
'获取数据库名
Public Function GetDatabase() As String
    GetDatabase = data.dataBase
End Function
'设置数据库名
Public Sub SetDatabase(curValue As String)
    data.dataBase = curValue
End Sub
'获取数据库地址
Public Function GetServerName() As String
    GetServerName = data.serverName
End Function
'设置数据库地址
Public Sub SetServerName(curValue As String)
    data.serverName = curValue
End Sub
'获取登录模式
Public Function GetEnterMode() As Boolean
    GetEnterMode = data.enterMode
End Function
'设置登录模式
Public Sub SetEnterMode(curValue As Boolean)
    data.enterMode = curValue
End Sub
'获取远程地址1
Public Function GetAddress1() As String
    GetAddress1 = data.address1
End Function
'设置远程地址1
Public Sub SetAddress1(curValue As String)
    data.address1 = curValue
End Sub
'获取远程地址2
Public Function GetAddress2() As String
    GetAddress2 = data.address2
End Function
'设置远程地址2
Public Sub SetAddress2(curValue As String)
    data.address2 = curValue
End Sub
'获取端口
Public Function GetPort() As String
    GetPort = data.port
End Function
'设置端口
Public Sub SetPort(curValue As String)
    data.port = curValue
End Sub
'错误处理
Public Sub DatabaseError()
    If data.enterMode = False Then
        ''重新获取远程地址
            NewServerName
        ''重新打开数据库
        If OpenData = False Then
            MsgBox "操作数据库出错！", vbCritical, "提示"
        Else
            MsgBox vbCrLf & "請重新操作一次当前任务！" & Err.Description, vbExclamation, "提示"
        End If
    Else
        MsgBox "操作数据库出错！" & vbCrLf & Err.Description, vbCritical, "提示"
    End If
End Sub

Public Function EnCode(ByVal s As String) As String '加密
    If Len(s) = 0 Then Exit Function
    Dim buff() As Byte
    buff = StrConv(s, vbFromUnicode)
    Dim i As Long
    Dim j As Byte
    Dim k As Byte, m As Byte
    Dim mstr As String
    mstr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyz"
    Dim outs As String
    i = UBound(buff) + 1
    outs = Space(2 * i)
    Dim temps As String
    For i = 0 To UBound(buff)
        Randomize Time
        j = CByte(5 * (Math.Rnd()) + 0) '最大产生的随机数只能是5，不能再大了,再大的话，就要多用一个字节
        buff(i) = buff(i) Xor j
        k = buff(i) Mod Len(mstr)
        m = buff(i) \ Len(mstr)
        m = m * 2 ^ 3 + j
        temps = Mid(mstr, k + 1, 1) + Mid(mstr, m + 1, 1)
        Mid(outs, 2 * i + 1, 2) = temps
     Next
     EnCode = outs
End Function

Public Function DeCode(ByVal s As String) As String '解密
    On Error GoTo myERR
    Dim i As Long
    Dim j As Byte
    Dim k As Byte
    Dim m As Byte
    Dim mstr As String
    mstr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyz"
    Dim T1 As String, T2 As String
    Dim buff() As Byte
    Dim n As Long
    n = 0
    For i = 1 To Len(s) Step 2
        T1 = Mid(s, i, 1)
        T2 = Mid(s, i + 1, 1)
        k = InStr(1, mstr, T1) - 1
        m = InStr(1, mstr, T2) - 1
        j = m \ 2 ^ 3
        m = m - j * 2 ^ 3
        ReDim Preserve buff(n)
        buff(n) = j * Len(mstr) + k
        buff(n) = buff(n) Xor m
        n = n + 1
     Next
     DeCode = StrConv(buff, vbUnicode)
     Exit Function
myERR:
     DeCode = ""
End Function

'对象删除
Private Sub Class_Terminate()
    CloseData
    Set cn = Nothing
End Sub