'
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
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
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
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
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
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