user.cls

本系统是一个报表分析查询系统

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "User"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

'//本类属性
Public Js_UserID As Long
Public Js_UserNumber As String
Public Js_UserName As String
Public Js_UserPass As String
Public Js_UserGroupList As String
Public Js_LogonPreceptID As Long
Public Js_RightID As Long
Public Js_Desc As String
Public Js_UseSign As Long
Public Js_HandsetCode As String
Public Js_EMailAddr As String
Public Js_PhoneCode As String
Public Js_WebAddr As String
Public Js_UserAdrr As String
Public Js_MailCode As String
Public Js_AddUserID As Long
Public Js_AddDate As String
Public Js_AddTime As String
Public Js_RightList As String

'//本类方案

'//保存用户 成功返回：True 失败返回False
Public Function Save(ByRef MsgInfo As String) As Boolean
 On Error GoTo ErrHandle
 Dim BaseObj As New StdRptBase.StdRptBaseCls
 Dim DaCn As New ADODB.Connection
 Dim Sql As String
 DaCn.ConnectionString = BaseObj.getConStr
 DaCn.Open
 DaCn.BeginTrans
 Sql = "delete from Js_User where Js_UserID=" & Js_UserID
 DaCn.Execute Sql
 Sql = "exec NewUser "
 Sql = Sql & Js_UserID & ","
 Sql = Sql & "'" & Js_UserNumber & "',"
 Sql = Sql & "'" & Js_UserName & "',"
 Sql = Sql & "'" & Js_UserPass & "',"
 Sql = Sql & "'" & Js_UserGroupList & "',"
 Sql = Sql & Js_LogonPreceptID & ","
 Sql = Sql & Js_RightID & ","
 Sql = Sql & "'" & Js_Desc & "',"
 Sql = Sql & Js_UseSign & ","
 Sql = Sql & "'" & Js_HandsetCode & "',"
 Sql = Sql & "'" & Js_EMailAddr & "',"
 Sql = Sql & "'" & Js_PhoneCode & "',"
 Sql = Sql & "'" & Js_WebAddr & "',"
 Sql = Sql & "'" & Js_UserAdrr & "',"
 Sql = Sql & "'" & Js_MailCode & "',"
 Sql = Sql & Js_AddUserID & ","
 Sql = Sql & "'" & Js_AddDate & "',"
 Sql = Sql & "'" & Js_AddTime & "',"
 Sql = Sql & "'" & Js_RightList & "'"
 DaCn.Execute Sql
 DaCn.CommitTrans
 DaCn.Close
 Set DaCn = Nothing
 Set BaseObj = Nothing
 MsgInfo = "保存用户成功"
 Save = True
 Exit Function
ErrHandle:
 MsgInfo = "保存用户，错误：" & Err.Description
 If DaCn.State = adStateOpen Then DaCn.Close
 Set DaCn = Nothing
 Set BaseObj = Nothing
 Save = False
End Function

'//装载用户信息 成功返回True 失败返回False
Public Function Load(ByVal lUserID As Long, ByRef MsgInfo As String) As Boolean
 On Error GoTo ErrHandle
 Dim BaseObj As New StdRptBase.StdRptBaseCls
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Sql = "select Js_UserID,Js_UserNumber,Js_UserName,Js_UserPass,Js_UserGroupList,Js_LogonPreceptID,Js_RightID,Js_Desc,Js_UseSign,Js_HandsetCode,Js_EMailAddr,Js_PhoneCode,Js_WebAddr,Js_UserAdrr,Js_MailCode,Js_AddUserID,Js_AddDate,Js_AddTime,Js_RightList from Js_User where Js_UserID=" & lUserID
 DaCn.ConnectionString = BaseObj.getConStr
 DaCn.Open
 DaRs.CursorLocation = adUseClient
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF Then
  If Not IsNull(DaRs("Js_UserID")) Then Js_UserID = DaRs("Js_UserID")
  If Not IsNull(DaRs("Js_UserNumber")) Then Js_UserNumber = Trim(DaRs("Js_UserNumber"))
  If Not IsNull(DaRs("Js_UserName")) Then Js_UserName = Trim(DaRs("Js_UserName"))
  If Not IsNull(DaRs("Js_UserPass")) Then Js_UserPass = Trim(DaRs("Js_UserPass"))
  If Not IsNull(DaRs("Js_UserGroupList")) Then Js_UserGroupList = Trim(DaRs("Js_UserGroupList"))
  If Not IsNull(DaRs("Js_LogonPreceptID")) Then Js_LogonPreceptID = DaRs("Js_LogonPreceptID")
  If Not IsNull(DaRs("Js_RightID")) Then Js_RightID = DaRs("Js_RightID")
  If Not IsNull(DaRs("Js_Desc")) Then Js_Desc = Trim(DaRs("Js_Desc"))
  If Not IsNull(DaRs("Js_UseSign")) Then Js_UseSign = DaRs("Js_UseSign")
  If Not IsNull(DaRs("Js_HandsetCode")) Then Js_HandsetCode = Trim(DaRs("Js_HandsetCode"))
  If Not IsNull(DaRs("Js_EMailAddr")) Then Js_EMailAddr = Trim(DaRs("Js_EMailAddr"))
  If Not IsNull(DaRs("Js_PhoneCode")) Then Js_PhoneCode = Trim(DaRs("Js_PhoneCode"))
  If Not IsNull(DaRs("Js_WebAddr")) Then Js_WebAddr = Trim(DaRs("Js_WebAddr"))
  If Not IsNull(DaRs("Js_UserAdrr")) Then Js_UserAdrr = Trim(DaRs("Js_UserAdrr"))
  If Not IsNull(DaRs("Js_MailCode")) Then Js_MailCode = Trim(DaRs("Js_MailCode"))
  If Not IsNull(DaRs("Js_AddUserID")) Then Js_AddUserID = DaRs("Js_AddUserID")
  If Not IsNull(DaRs("Js_AddDate")) Then Js_AddDate = Trim(DaRs("Js_AddDate"))
  If Not IsNull(DaRs("Js_AddTime")) Then Js_AddDate = Trim(DaRs("Js_AddTime"))
  If Not IsNull(DaRs("Js_RightList")) Then Js_RightList = Trim(DaRs("Js_RightList"))
 Else
  MsgInfo = "错误的用户"
  DaRs.Close
  DaCn.Close
  Set DaRs = Nothing
  Set DaCn = Nothing
  Set BaseObj = Nothing
  Load = False
  Exit Function
 End If
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 Set BaseObj = Nothing
 MsgInfo = "装载数据成功"
 Load = True
 Exit Function
ErrHandle:
 MsgInfo = "装载用户，错误：" & Err.Description
 If DaRs.State = adStateOpen Then DaRs.Close
 If DaCn.State = adStateOpen Then DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 Set BaseObj = Nothing
 Load = False
End Function

'//删除用户
Public Function Del(ByVal lUserID As Long, ByRef MsgInfo As String) As Boolean
 On Error GoTo ErrHandle
 Dim DelSign As Long
 Dim BaseObj As New StdRptBase.StdRptBaseCls
 Dim DaCn As New ADODB.Connection
 Dim Sql As String
 '//
 If Load(lUserID, MsgInfo) = False Then
  Del = False
  Exit Function
 End If
 '//
 DelSign = MsgBox("删除[" & Js_UserName & "]？", vbQuestion + vbYesNo + vbDefaultButton2, BaseObj.getMsgInfo)
 If DelSign <> 6 Then
  Set DaCn = Nothing
  Set BaseObj = Nothing
  MsgInfo = "用户取消删除操作"
  Del = False
  Exit Function
 End If
 '//
 Sql = "delete from Js_User where Js_UserID=" & lUserID
 DaCn.ConnectionString = BaseObj.getConStr
 DaCn.Open
 DaCn.Execute Sql
 DaCn.Close
 Set DaCn = Nothing
 Set BaseObj = Nothing
 MsgInfo = "删除[" & Js_UserName & "]成功"
 Del = True
 Exit Function
ErrHandle:
 If DaCn.State = adStateOpen Then DaCn.Close
 Set DaCn = Nothing
 Set BaseObj = Nothing
 MsgInfo = "删除用户，错误：" & Err.Description
 Del = False
End Function

'//计算指定的用户下面属于多少个用户组
Public Function getUserGroupCount(ByVal lUserID As Long) As Long
 On Error GoTo ErrHandle
 Dim BaseObj As New StdRptBase.StdRptBaseCls
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Dim RetValue As Long
 RetValue = 0
 Sql = "select count(*) as UserGroupCount from Js_UserGroup where Js_UserList like '%|" & lUserID & "|%'"
 DaCn.ConnectionString = BaseObj.getConStr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF And Not IsNull(DaRs("UserGroupCount")) Then
  RetValue = DaRs("UserGroupCount")
 End If
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 getUserGroupCount = RetValue
 Exit Function
ErrHandle:
 If DaRs.State = adStateOpen Then DaRs.Close
 If DaCn.State = adStateOpen Then DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 Set BaseObj = Nothing
 getUserGroupCount = 0
End Function

'//统计当前用户组的数量
Public Function getSum() As Long
 On Error GoTo ErrHandle
 Dim BaseObj As New StdRptBase.StdRptBaseCls
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Dim RetValue As Long
 Sql = "select count(*) as UserSum from Js_User"
 DaCn.ConnectionString = BaseObj.getConStr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF And Not IsNull(DaRs("UserSum")) Then
  RetValue = DaRs("UserSum")
 End If
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 getSum = RetValue
 Exit Function
ErrHandle:
 If DaRs.State = adStateOpen Then DaRs.Close
 If DaCn.State = adStateOpen Then DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 Set BaseObj = Nothing
 getSum = 0
End Function

'//从金蝶中导入用户
Public Function UserImport(ByRef MsgInfo As String) As Boolean
 On Error GoTo ErrHandle
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Dim tSql() As String
 Dim ImpUser As UserStruct
 Dim ImpUserGroup As UserGroupStruct
 Dim tlMin As Integer
 Dim tlMax As Integer
 Dim iLoop As Integer
 Dim iSn As Integer
 Dim meObj As New StdRptBase.StdRptBaseCls
 
 Sql = "select Js_GroupID from Js_UserGroup where Js_GroupName='金蝶用户组'"
 DaCn.ConnectionString = meObj.getConStr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF And Not IsNull(DaRs("Js_GroupID")) Then
  ImpUserGroup.Js_GroupID = DaRs("Js_GroupID")
 End If
 DaRs.Close
 iSn = 0
 '//删除原来的金蝶用户组
 Sql = "delete from Js_UserGroup where Js_GroupName='金蝶用户组'"
 iSn = iSn + 1
 ReDim Preserve tSql(1 To iSn)
 tSql(iSn) = Sql
 '//删除用户
 Sql = "delete from js_user where js_usergrouplist='^" & ImpUserGroup.Js_GroupID & "^'"
 iSn = iSn + 1
 ReDim Preserve tSql(1 To iSn)
 tSql(iSn) = Sql
 '//插入新的用户组
 With ImpUserGroup
  '//用户组内码
  If .Js_GroupID = 0 Then
   .Js_GroupID = meObj.getItemID(13)
  Else
   .Js_GroupID = .Js_GroupID
  End If
  '//
  .Js_ParentID = 0
  .Js_Number = "0x"
  .Js_GroupName = "金蝶用户组"
  .Js_UserList = "^1^"
  .Js_Admin = 1
  .Js_RightID = 0
  .Js_Desc = "由金蝶K/3系统中导入的用户"
  .Js_Level = 1
  .Js_Detail = 1
  .Js_UseSign = 1
  .Js_UserID = UserID
  .Js_Date = meObj.GetServerDate(1)
  .Js_Time = meObj.GetServerDate(2)
  '//
  Sql = "exec NewUserGroup "
  Sql = Sql & .Js_GroupID & ","
  Sql = Sql & .Js_ParentID & ","
  Sql = Sql & "'" & .Js_Number & "',"
  Sql = Sql & "'" & .Js_GroupName & "',"
  Sql = Sql & "'" & .Js_UserList & "',"
  Sql = Sql & .Js_Admin & ","
  Sql = Sql & .Js_RightID & ","
  Sql = Sql & "'" & .Js_Desc & "',"
  Sql = Sql & .Js_Level & ","
  Sql = Sql & .Js_Detail & ","
  Sql = Sql & .Js_UseSign & ","
  Sql = Sql & .Js_UserID & ","
  Sql = Sql & "'" & .Js_Date & "',"
  Sql = Sql & "'" & .Js_Time & "'"
 End With
 '//插入新的用户组
 iSn = iSn + 1
 ReDim Preserve tSql(1 To iSn)
 tSql(iSn) = Sql
 '//开始插入新的用户
 Sql = "select fname from t_user where fuserid>16300 order by fname asc"
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF Then
  While Not DaRs.EOF
   With ImpUser
    '//判断用户内码
    If .Js_UserID = 0 Then
     .Js_UserID = meObj.getItemID(12)
    Else
     .Js_UserID = .Js_UserID + 1
    End If
    '//
    .Js_UserNumber = "0x"
    If Not IsNull(DaRs("fname")) Then .Js_UserName = Trim(DaRs("fname")) Else .Js_UserName = ""
    .Js_UserPass = meObj.getMd5Pass("Kingdee", 32)
    .Js_UserGroupList = "^" & ImpUserGroup.Js_GroupID & "^"
    .Js_LogonPreceptID = 1
    .Js_RightID = 1
    .Js_Desc = "金蝶K/3用户[" & .Js_UserName & "]"
    .Js_UseSign = 1
    .Js_HandsetCode = ""
    .Js_EMailAddr = ""
    .Js_PhoneCode = ""
    .Js_WebAddr = ""
    .Js_UserAdrr = ""
    .Js_MailCode = ""
    .Js_AddUserID = UserID
    .Js_AddDate = meObj.GetServerDate(1)
    .Js_AddTime = meObj.GetServerDate(2)
    .Js_RightList = ""
    '//
    Sql = "exec NewUser "
    Sql = Sql & .Js_UserID & ","
    Sql = Sql & "'" & .Js_UserNumber & "',"
    Sql = Sql & "'" & .Js_UserName & "',"
    Sql = Sql & "'" & .Js_UserPass & "',"
    Sql = Sql & "'" & .Js_UserGroupList & "',"
    Sql = Sql & .Js_LogonPreceptID & ","
    Sql = Sql & .Js_RightID & ","
    Sql = Sql & "'" & .Js_Desc & "',"
    Sql = Sql & .Js_UseSign & ","
    Sql = Sql & "'" & .Js_HandsetCode & "',"
    Sql = Sql & "'" & .Js_EMailAddr & "',"
    Sql = Sql & "'" & .Js_PhoneCode & "',"
    Sql = Sql & "'" & .Js_WebAddr & "',"
    Sql = Sql & "'" & .Js_UserAdrr & "',"
    Sql = Sql & "'" & .Js_MailCode & "',"
    Sql = Sql & .Js_AddUserID & ","
    Sql = Sql & "'" & .Js_AddDate & "',"
    Sql = Sql & "'" & .Js_AddTime & "',"
    Sql = Sql & "'" & .Js_RightList & "'"
   End With
   iSn = iSn + 1
   ReDim Preserve tSql(1 To iSn)
   tSql(iSn) = Sql
   DaRs.MoveNext
  Wend
 End If
 DaRs.Close
 Set DaRs = Nothing
 '//
 tlMin = LBound(tSql)
 tlMax = UBound(tSql)
 DaCn.BeginTrans
 For iLoop = tlMin To tlMax
  '//MsgBox tSql(iLoop)
  DaCn.Execute tSql(iLoop)
 Next
 DaCn.CommitTrans
 DaCn.Close
 Set DaCn = Nothing
 MsgInfo = "导入金蝶K/3用户成功"
 UserImport = True
 Exit Function
ErrHandle:
 MsgInfo = "导入金蝶K/3用户失败" & Chr(13) & "错误：" & Err.Description
 UserImport = False
End Function