VB常用类

'clsADO
Option Explicit
Dim sIniFilePath As String
Dim sSort As String
Dim sDataSource As String   '数据源
Dim sDataBase As String     '数据库名
Dim sUser As String         '用户名
Dim sPass As String         '密码
Dim cn As New ADODB.Connection
Dim cED As New clsED
Dim cOperationINI As New clsOperationINI
Dim cWriteLog As New clsWriteLog

Private Sub class_initialize()
    '读取相关设定
    sIniFilePath = App.Path & "project.ini"
    sSort = cED.fUserCode(Trim("Data"))
    sDataBase = cED.fUserCode(Trim("database"))
    sDataSource = cED.fUserCode(Trim("datasource"))
    sUser = cED.fUserCode(Trim("user"))
    sPass = cED.fUserCode(Trim("pass"))
    Set cED = New clsED
    Set cOperationINI = New clsOperationINI
    sDataBase = Trim(cOperationINI.myReadINI(sIniFilePath, sSort, sDataBase, ""))
    sDataSource = Trim(cOperationINI.myReadINI(sIniFilePath, sSort, sDataSource, ""))
    sUser = Trim(cOperationINI.myReadINI(sIniFilePath, sSort, sUser, ""))
    sPass = Trim(cOperationINI.myReadINI(sIniFilePath, sSort, sPass, ""))
    sDataBase = cED.fUserDeCode(Left(sDataBase, Len(sDataBase) - 1))
    sDataSource = cED.fUserDeCode(Left(sDataSource, Len(sDataSource) - 1))
    sUser = cED.fUserDeCode(Left(sUser, Len(sUser) - 1))
    sPass = cED.fUserDeCode(Left(sPass, Len(sPass) - 1))
End Sub

Private Sub class_terminate()
    Set cED = Nothing
    Set cOperationINI = Nothing
    Set cn = Nothing
End Sub

'***************************************************************************
'函数名: fgetConnection
'功  能: 设置Connection
'制作人: inrg
'参  数: 无
'返回值: ADODB.Connection
'***************************************************************************

Private Function fgetConnection() As ADODB.Connection
On Error GoTo ErrMsg
    cn.ConnectionString = "Provider=SQLOLEDB.1;Password=" & sPass & ";Persist Security Info=True;User ID=" & sUser & ";Initial Catalog=" & sDataBase & ";Data Source=" & sDataSource
    cn.Open
    Set fgetConnection = cn
Exit Function
ErrMsg:
    cWriteLog.fWriteErrMsg "clsADO", "fgetConnection", Err.Number, Err.Source, Err.Description
End Function

'***************************************************************************
'函数名: fExecute
'功  能: 执行SQL语句
'制作人: inrg
'参  数: sqlStr 执行语句
'返回值: True=成功,False=失败
'***************************************************************************
Public Function fExecute(ByVal sqlStr As Variant) As Boolean
On Error GoTo ErrorMsg
    Set cn = fgetConnection()
    cn.Execute sqlStr
    fExecute = True
Exit Function
ErrorMsg:
    fExecute = False
    cWriteLog.fWriteErrMsg "clsADO", "fExecute", Err.Number, Err.Source, Err.Description
End Function

'***************************************************************************
'函数名: fQuery
'功  能: 查询
'制作人: inrg
'参  数: sqlStr 执行语句
'参  数: rs     Recordset
'返回值: True=成功,False=失败
'***************************************************************************
Public Function fQuery(ByVal sqlStr As Variant, ByRef rs As Variant) As Boolean
On Error GoTo ErrorMsg
    Set rs = New ADODB.Recordset
    Set cn = fgetConnection()
    rs.Open sqlStr, cn, 3, 1
    fQuery = True
Exit Function
ErrorMsg:
    fQuery = False
    cWriteLog.fWriteErrMsg "clsADO", "fQuery", Err.Number, Err.Source, Err.Description
End Function

 

 

'clsED

    'http://blog.csdn.net/neil/archive/2001/05/25/3009.aspx
Dim cWriteLog As New clsWriteLog

Private Function UserCode(password As String) As String
On Error GoTo ErrMsg
'用户口令加密
    Dim il_bit, il_x, il_y, il_z, il_len, i As Long
    Dim is_out As String
    il_len = Len(password)
    il_x = 0
    il_y = 0
    is_out = ""
    For i = 1 To il_len
        il_bit = AscW(Mid(password, i, 1))    'W系列支持unicode
        
        il_y = (il_bit * 13 Mod 256) + il_x
        is_out = is_out & ChrW(Fix(il_y))  '取整 int和fix区别: fix修正负数
        il_x = il_bit * 13 / 256
    Next
    is_out = is_out & ChrW(Fix(il_x))
    
    password = is_out
    il_len = Len(password)
    il_x = 0
    il_y = 0
    is_out = ""
    For i = 1 To il_len
        il_bit = AscW(Mid(password, i, 1))
        '取前4位值
        il_y = il_bit / 16 + 64
        is_out = is_out & ChrW(Fix(il_y))
        '取后4位值
        il_y = (il_bit Mod 16) + 64
        is_out = is_out & ChrW(Fix(il_y))
    Next
    UserCode = is_out
Exit Function
ErrMsg:
    cWriteLog.fWriteErrMsg "clsED", "UserCode", Err.Number, Err.Source, Err.Description
End Function

Private Function UserDeCode(password As String) As String
On Error GoTo ErrMsg
'口令解密
    Dim is_out As String
    Dim il_x, il_y, il_len, i, il_bit As Long

    il_len = Len(password)
    il_x = 0
    il_y = 0
    is_out = ""
    For i = 1 To il_len Step 2
        il_bit = AscW(Mid(password, i, 1))
        '取前4位值
        il_y = (il_bit - 64) * 16
        '取后4位值
        'dd = AscW(Mid(password, i + 1, 1)) - 64
        il_y = il_y + AscW(Mid(password, i + 1, 1)) - 64
        is_out = is_out & ChrW(il_y)
    Next

    il_x = 0
    il_y = 0
    password = is_out
    is_out = ""

    il_len = Len(password)
    il_x = AscW(Mid(password, il_len, 1))

    For i = (il_len - 1) To 1 Step -1
        il_y = il_x * 256 + AscW(Mid(password, i, 1))
        il_x = il_y Mod 13
        is_out = ChrW(Fix(il_y / 13)) & is_out
    Next
    UserDeCode = is_out
Exit Function
ErrMsg:
    cWriteLog.fWriteErrMsg "clsED", "UserDeCode", Err.Number, Err.Source, Err.Description
End Function

Public Function fUserCode(sStr As String) As String
On Error GoTo ErrMsg
    Dim i As Integer
    For i = 1 To 3
        sStr = UserCode(sStr)
    Next
    fUserCode = sStr
Exit Function
ErrMsg:
    cWriteLog.fWriteErrMsg "clsED", "fUserCode", Err.Number, Err.Source, Err.Description
End Function

Public Function fUserDeCode(sStr As String) As String
On Error GoTo ErrMsg
    Dim i As Integer
    For i = 1 To 3
        sStr = UserDeCode(sStr)
    Next
    fUserDeCode = sStr
Exit Function
ErrMsg:
    cWriteLog.fWriteErrMsg "clsED", "fUserDeCode", Err.Number, Err.Source, Err.Description
End Function

 

 

'clsOperationINI
Option Explicit

'访问INI的函数
'用法：
'myReadINI　 读INI
'myWriteINI　写INI
'用法与读写注册表很类似
Dim cWriteLog As New clsWriteLog
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal AppName As String, ByVal KeyName As String, ByVal keydefault As String, ByVal Filename As String) As Long

Public Function myReadINI(inifile, inisection, inikey, iniDefault)

'Fail fracefully if no file / wrong file is specified.
'If no section (appname), default is first appname
'if no key, default is first key
On Error GoTo ErrMsg
    Dim lpApplicationName As String
    Dim lpKeyName As String
    Dim lpDefault As String
    Dim lpReturnedString As String
    Dim nSize As Long
    Dim lpFileName As String
    Dim retval As Long
    Dim Filename As String
    lpDefault = Space$(254)
    lpDefault = iniDefault

    lpReturnedString = Space$(254)

    nSize = 254
    lpFileName = inifile
    lpApplicationName = inisection
    lpKeyName = inikey
    Filename = lpFileName
    retval = GetPrivateProfileString(lpApplicationName, lpKeyName, lpDefault, lpReturnedString, nSize, lpFileName)
    myReadINI = lpReturnedString
Exit Function
ErrMsg:
    cWriteLog.fWriteErrMsg "clsOperationINI", "myReadINI", Err.Number, Err.Source, Err.Description
End Function


Public Function myWriteINI(inifile As String, inisection As String, inikey As String, Info As String) As String
On Error GoTo ErrMsg
    Dim retval As Long
    retval = WritePrivateProfileString(inisection, inikey, Info, inifile)
    myWriteINI = LTrim$(Str$(retval))
Exit Function
ErrMsg:
    cWriteLog.fWriteErrMsg "clsOperationINI", "myReadINI", Err.Number, Err.Source, Err.Description
End Function

 

 

'clsCommand
Option Explicit
Public cPageSize As Integer
Private cOperationINI As clsOperationINI
Private cWriteLog As clsWriteLog

Private Sub class_initialize()
On Error GoTo ErrMsg
    Set cOperationINI = New clsOperationINI
    Set cWriteLog = New clsWriteLog
    cPageSize = CInt(cOperationINI.myReadINI(App.Path & "project.ini", "page", "pagesize", ""))
Exit Sub
ErrMsg:
    cWriteLog.fWriteErrMsg "clsCommand", "class_initialize", Err.Number, Err.Source, Err.Description
End Sub

Private Sub class_terminate()
    Set cOperationINI = Nothing
End Sub

 

 

'clsWriteLog
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

Option Explicit
Dim cED As New clsED
Dim cWriteLog As New clsWriteLog
Public Function fWriteErrMsg(ByVal sClassName As String, ByVal sFunName As String, ByVal sNumber As String, ByVal sSource As String, ByVal sDescription As String)
    Dim dateStr As Variant
    Dim sFilePath As String

    sFilePath = App.Path & "Log"
    dateStr = Time & " " & Timer

    If Dir(sFilePath, vbDirectory) = "" Then
        MkDir sFilePath
    End If
    sFilePath = sFilePath & "" & Date & ".log"
    WritePrivateProfileString dateStr, "类  名", sClassName, sFilePath
    WritePrivateProfileString dateStr, "函数名", sFunName, sFilePath
    WritePrivateProfileString dateStr, "出错代码", sNumber, sFilePath
    WritePrivateProfileString dateStr, "对  象", sSource, sFilePath
    WritePrivateProfileString dateStr, "错误描叙", sDescription, sFilePath
End Function