clsdataconn.cls

FLA-502控制、标定、分析用

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsDataConn"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'*************************
'系统数据库设置
'*************************

Option Explicit
Private szConnStr As String
Private szLgDownConnstr As String
Private szFileName As String
Private TestDn As ADODB.Connection
'------------------------------------------------------------------
'数据库连接类
'------------------------------------------------------------------
'------------------------------------------------------------------
'类初始化
'------------------------------------------------------------------
Private Sub Class_Initialize()
    szConnStr = ""
End Sub
'------------------------------------------------------------------
'取连接字串
'------------------------------------------------------------------
Public Function GetConnectionString() As String
    On Error GoTo Err_1
    szConnStr = GetConnStr()
    szConnStr = GetEncryptString(szConnStr)            '将密码转换为明码

    GetConnectionString = szConnStr
    Exit Function
Err_1:
    If Err.Number <> 0 Then
        MsgBox "Err Number:" + CStr(Err.Number) + vbCrLf + "Err Description:" + Err.Description, vbCritical + vbOKOnly, "提示"
    Else
        MsgBox "程序出现错误，请与开发商联系!", vbCritical + vbOKOnly, "提示"
    End If
End Function

Public Function GetLgDownConnectionString() As String
    On Error GoTo Err_1
    szLgDownConnstr = GetLgDownConnStr()
    szLgDownConnstr = GetEncryptString(szLgDownConnstr)            '将密码转换为明码
    GetLgDownConnectionString = szLgDownConnstr
    Exit Function
Err_1:
    If Err.Number <> 0 Then
        MsgBox "Err Number:" + CStr(Err.Number) + vbCrLf + "Err Description:" + Err.Description, vbCritical + vbOKOnly, "提示"
    Else
        MsgBox "程序出现错误，请与开发商联系!", vbCritical + vbOKOnly, "提示"
    End If
End Function

Private Function GetConnStr() As String
    Dim nFile As String
    Dim szStr As String
On Error GoTo Err_1
    Err.Number = 0
    Dim cls注册表 As New clsRegisterKey
    szStr = cls注册表.GetKeyValue(HKEY_CURRENT_USER, "DS", "DC")
    GetConnStr = szStr
    Exit Function
Err_1:
    If Err.Number <> 0 Then
        MsgBox "Err Number:" + CStr(Err.Number) + vbCrLf + "Err Description:" + Err.Description, vbCritical + vbOKOnly, "提示"
    Else
        MsgBox "程序出现错误，请与开发商联系!", vbCritical + vbOKOnly, "提示"
    End If
End Function

Private Function GetLgDownConnStr() As String
    Dim nFile As String
    Dim szStr As String
On Error GoTo Err_1
    Err.Number = 0
    Dim cls注册表 As New clsRegisterKey
    szStr = cls注册表.GetKeyValue(HKEY_CURRENT_USER, "DS", "LDDC")
    GetLgDownConnStr = szStr
    Exit Function
Err_1:
    If Err.Number <> 0 Then
        MsgBox "Err Number:" + CStr(Err.Number) + vbCrLf + "Err Description:" + Err.Description, vbCritical + vbOKOnly, "提示"
    Else
        MsgBox "程序出现错误，请与开发商联系!", vbCritical + vbOKOnly, "提示"
    End If
End Function

Private Function GetDotNetConnStr() As String
    Dim nFile As String
    Dim szStr As String
    On Error GoTo Err_1
    Err.Number = 0
    Dim cls注册表 As New clsRegisterKey
    szStr = cls注册表.GetKeyValue(HKEY_CURRENT_USER, "DS", "DCDOT")
    GetDotNetConnStr = szStr
    Exit Function
Err_1:
    If Err.Number <> 0 Then
        MsgBox "Err Number:" + CStr(Err.Number) + vbCrLf + "Err Description:" + Err.Description, vbCritical + vbOKOnly, "提示"
    Else
        MsgBox "程序出现错误，请与开发商联系!", vbCritical + vbOKOnly, "提示"
    End If
End Function

'-------------
'写连接字串
'-------------
Public Function WriteConnectionString(ByVal szConnStr As String, ByVal szLgDownConnstr As String)
    Dim nFile As String
    Dim szStr As String
    Dim szLgDownStr As String
On Error GoTo Err_1
    Err.Number = 0
    Dim strConnForVB As String
    Dim strConnForDotNet As String
    strConnForVB = GetEncryptString(szConnStr)
    szLgDownStr = GetEncryptString(szLgDownConnstr)
    Dim cls注册表 As New clsRegisterKey
    szStr = cls注册表.UpdateKey(HKEY_CURRENT_USER, "DS", "DC", strConnForVB)
    szStr = cls注册表.UpdateKey(HKEY_CURRENT_USER, "DS", "LDDC", szLgDownStr)
    Dim i As Integer
    Dim strChar As String
    Dim nStart As Integer
    For i = 1 To Len(szConnStr)
      strChar = Mid(szConnStr, i, 1)
      If strChar = ";" Then
         nStart = i
         Exit For
      End If
    Next
    strConnForDotNet = Mid(szConnStr, nStart + 1, Len(szConnStr) - nStart)
    strConnForDotNet = GetEncryptString(strConnForDotNet)
    szStr = cls注册表.UpdateKey(HKEY_CURRENT_USER, "DS", "DCDOT", strConnForDotNet)
    Exit Function
Err_1:
    If Err.Number <> 0 Then
        MsgBox "Err Number:" + CStr(Err.Number) + vbCrLf + "Err Description:" + Err.Description, vbCritical + vbOKOnly, "提示"
    Else
        MsgBox "程序出现错误，请与开发商联系!", vbCritical + vbOKOnly, "提示"
    End If
End Function

'-------------------------------------------------------------------------
'数据加密过程：原理进行位换位的ASD加密码方法，明码与密码的变换过程一致
'-------------------------------------------------------------------------
Private Function GetEncryptString(ByVal Str1 As String) As String
  Dim SaveStr As String
  Dim vs As String
  Dim i As Integer
'On Error Resume Next
  Dim nLen As Integer
  nLen = Len(Str1)
  For i = 1 To Len(Str1)
    vs = Mid(Str1, i, 1)
    If Abs(Asc(vs)) > 127 Then
        MsgBox "密码不能使用汉字!", vbInformation + vbOKOnly, "提示"
        GetEncryptString = ""
        Exit Function
    End If
    SaveStr = SaveStr + ConVert(vs)
  Next
  GetEncryptString = SaveStr
End Function
Private Function ConVert(ByVal Opstr As String) As String
  Dim i As Integer
  Dim n1 As Integer
  Dim vn As Double
  Dim Str1 As String
  Dim Str2 As String
'On Error Resume Next
  vn = Asc(Opstr)
  Str1 = ""
  Do While vn <> 0
    i = vn Mod 2
    Str1 = CStr(i) + Str1
    vn = Fix(vn / 2)
  Loop
  If Len(Str1) < 8 Then
    n1 = 8 - Len(Str1)
    For i = 1 To n1
      Str1 = "0" + Str1
    Next
  End If
  ConVert = ConVpass(Str1)
End Function

Private Function ConVpass(ByVal Str1 As String) As String
  Dim vn(8) As String
  Dim i As Integer
  Dim st As String
  Dim N As Integer
'On Error Resume Next
  For i = 1 To 8
    vn(i - 1) = Mid(Str1, i, 1)
  Next
  st = vn(0) + vn(7) + vn(6) + vn(5) + vn(4) + vn(3) + vn(2) + vn(1)
  For i = 1 To 8
    N = N + CInt(Mid(st, i, 1)) * 2 ^ (8 - i)
  Next
  ConVpass = Chr(N)
End Function

'------------------------------------------------------------------
'类的结束
'------------------------------------------------------------------
Private Sub Class_Terminate()
'On Error Resume Next
    If Not (TestDn Is Nothing) Then
        If (TestDn.State = adStateOpen) Then
            TestDn.Close
        End If
        Set TestDn = Nothing
    End If
End Sub