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