clssystem.cls

来自「很好！ 很实用！ 免费！」· CLS 代码 · 共 280 行

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsSystem"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'****************************************
'存放系统函数
'****************************************
Option Explicit
'注册表项
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
'存放可以查询库存的仓库
'结构:WHID,iSort,iLocal,iOwner
'维数多了一个结构;arrInventorySearchWarehouse(0,x)是没有意义的
Public Property Get File() As clsFile
    Set File = New clsFile
End Property

Public Property Get Busy() As clsSysBusy
    Set Busy = New clsSysBusy
End Property
Public Property Get Area() As clsArea
    Set Area = New clsArea
End Property
'初始化系统参数
Public Function InitSystem() As Boolean
Dim rsTemp As ADODB.Recordset
Dim sSQL As String
'On Error GoTo Err:
'init
    Set g_cn = New ADODB.Connection
    Set rsTemp = New ADODB.Recordset
    
    sSQL = ""
    g_sUserID = ""
    g_sUserName = ""
'init temp file
    Call File.InitFileList
    If Not getRegString() Then 'no permission
        End
    End If
    g_cn.ConnectionString = g_cnString
    g_cn.CursorLocation = adUseClient
    g_cn.Open
    
    InitSystem = True
    Exit Function
Err:
    InitSystem = False
End Function
'删除注册表
Function delRegString() As Boolean
Dim hKey As Long
Dim ret As Long
    
    ret = RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\InnerSystem", hKey)
    ret = RegDeleteKey(hKey, "")
    If ret = 0 Then
        delRegString = True
    Else
        delRegString = False
    End If
    RegCloseKey hKey
End Function
'从注册表中设置键值
Public Function setRegString() As Boolean
Dim hKey As Long
Dim ret As Long
Dim sToolBar As String
Dim sMenuTree As String
Dim sStatusBar As String
Dim sButtonArrange As String

    ret = RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\", hKey)
    If ret = 0 Then
        'ToolBar
        If g_ToolBar = True Then
            sToolBar = "1"
        Else
            sToolBar = "0"
        End If
        'MenuTree
        If g_MenuTree = True Then
            sMenuTree = "1"
        Else
            sMenuTree = "0"
        End If
        'StatusBar
        If g_StatusBar = True Then
            sStatusBar = "1"
        Else
            sStatusBar = "0"
        End If
        'ButtonArrange
        If g_ButtonArrange = True Then
            sButtonArrange = "1"
        Else
            sButtonArrange = "0"
        End If
        
        ret = RegSetValueEx(hKey, "ToolBar", 0, 1, ByVal sToolBar, 1)
        ret = RegSetValueEx(hKey, "MenuTree", 0, 1, ByVal sMenuTree, 1)
        ret = RegSetValueEx(hKey, "ButtonArrange", 0, 1, ByVal sButtonArrange, 1)
        ret = RegSetValueEx(hKey, "StatusBar", 0, 1, ByVal sStatusBar, 1)
    End If
    RegCloseKey hKey
    setRegString = True
End Function
'从注册表中取到连接串
Public Function getRegString() As Boolean
Dim ret As Long
Dim hKey As Long
Dim lenData As Long
Dim typeData As Long
Dim vbNullString As String
Dim sCNString As String
Dim oDataLinks As DataLinks
Dim sToolBar As String
Dim sMenuTree As String
Dim sStatusBar As String
Dim sButtonArrange As String
Dim sDebug As String
Dim sID As String
Dim cnString As String

    getRegString = True
    
    ret = RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\InnerSystem", hKey)
    If ret = 0 Then
        'ID
        ret = RegQueryValueEx(hKey, "ID", 0, typeData, ByVal vbNullString, lenData)
        If ret = 0 Then
            sID = String(lenData, Chr(0))
            RegQueryValueEx hKey, "ID", 0, typeData, ByVal sID, lenData
            sID = Left(sID, InStr(sID, Chr(0)) - 1)
        End If
        'ConStr
        ret = RegQueryValueEx(hKey, "ConStr", 0, typeData, ByVal vbNullString, lenData)
        If ret = 0 Then
            cnString = String(lenData, Chr(0))
            RegQueryValueEx hKey, "ConStr", 0, typeData, ByVal cnString, lenData
            cnString = Left(cnString, InStr(cnString, Chr(0)) - 1)
        End If
        g_cnString = Decipher(sID, cnString)
        'ToolBar
        sToolBar = Chr(0)
        ret = RegQueryValueEx(hKey, "ToolBar", 0, typeData, ByVal sToolBar, lenData)
        If sToolBar = "1" Then
            g_ToolBar = True
        Else
            g_ToolBar = False
        End If
        'MenuTree
        sMenuTree = Chr(0)
        ret = RegQueryValueEx(hKey, "MenuTree", 0, typeData, ByVal sMenuTree, lenData)
        If sMenuTree = "1" Then
            g_MenuTree = True
        Else
            g_MenuTree = False
        End If
        'StatusBar
        sStatusBar = Chr(0)
        ret = RegQueryValueEx(hKey, "StatusBar", 0, typeData, ByVal sStatusBar, lenData)
        If sStatusBar = "1" Then
            g_StatusBar = True
        Else
            g_StatusBar = False
        End If
        'ButtonArrange
        sButtonArrange = Chr(0)
        ret = RegQueryValueEx(hKey, "ButtonArrange", 0, typeData, ByVal sButtonArrange, lenData)
        If sButtonArrange = "1" Then
            g_ButtonArrange = True
        Else
            g_ButtonArrange = False
        End If
        'Debug
        sDebug = Chr(0)
        ret = RegQueryValueEx(hKey, "Debug", 0, typeData, ByVal sDebug, lenData)
        If sDebug = "1" Then
            g_Debug = True
        Else
            g_Debug = False
        End If
        
    Else
        Set oDataLinks = New DataLinks
        cnString = oDataLinks.PromptNew
        ret = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWARE\InnerSystem", hKey)
        'Default
        g_cnString = cnString
        g_ButtonArrange = True
        g_MenuTree = True
        g_StatusBar = True
        g_ToolBar = True
        'set string
        If Not ret Then
            sID = newGUID()
            
            ret = RegSetValueEx(hKey, "ID", 0, 1, ByVal sID, 255)
            ret = RegSetValueEx(hKey, "ConStr", 0, 1, ByVal Cipher(sID, cnString), 255)
            ret = RegSetValueEx(hKey, "AppVersion", 0, 1, ByVal App.Major & "." & App.Minor & "." & App.Revision, 10)
            ret = RegSetValueEx(hKey, "ToolBar", 0, 1, ByVal "1", 1)
            ret = RegSetValueEx(hKey, "MenuTree", 0, 1, ByVal "1", 1)
            ret = RegSetValueEx(hKey, "ButtonArrange", 0, 1, ByVal "1", 1)
            ret = RegSetValueEx(hKey, "StatusBar", 0, 1, ByVal "1", 1)
            ret = RegSetValueEx(hKey, "Debug", 0, 1, ByVal "0", 1)
            ret = RegSetValueEx(hKey, "User", 0, 1, ByVal NTDomainUserName(), 30)
        End If
    End If
    RegCloseKey hKey
    getRegString = True
End Function

'用户登录
Public Function ValidateUser(sUserName As String, sPassword As Variant) As Boolean
Dim sSQL As String
Dim rsTemp As ADODB.Recordset
Dim ws As Object
    Set ws = CreateObject("MSWinsock.Winsock")
    
    'init
    sSQL = ""
    Set rsTemp = New ADODB.Recordset
    'body
    sSQL = "select ID,Name from hrEmployee where Logon='是' and  (No=" + CheckString(sUserName) + " or LoginName=" + CheckString(sUserName) + ") and Password=" + CheckString(sPassword)
    rsTemp.Open sSQL, g_cn, adOpenStatic, adLockOptimistic
    If rsTemp.EOF Then
        ValidateUser = False
    Else
        g_sUserID = rsTemp(0).value
        g_sUserName = rsTemp(1).value
        rsTemp.Close
        ValidateUser = True
    End If
    'dispose
    Set rsTemp = Nothing
    Set ws = Nothing
End Function


Public Function AddLog(ByVal sObjectName As String, ByVal sMsg As String, Optional ByVal iType As Integer = 1)
Dim sType As String
    Select Case iType
        Case 1
            sType = UCase(Mid(Trim(sMsg), 1, 6))
        Case 2 'insert
            sType = "INSERT"
        Case 3 'update
            sType = "UPDATE"
        Case 4 'delete
            sType = "DELETE"
    End Select
    'g_cn.Execute "insert into dy_sTempLog (EmpID,TranDate,TranType,ObjectName,MSG) values (" + CStr(g_sUserID) + ",getDate()," + CheckString(SType, ",") + CheckString(sObjectName, ",") + CheckString(sMsg, ")")
    
End Function
Public Sub LogonOut()
    Set g_cn = Nothing
    g_cnString = ""
    g_sUserID = ""
    g_sUserName = ""
End Sub