authfile.bas

通用书店管理系统

Attribute VB_Name = "Auth_Fun"
Option Explicit
'检查用户权限(blnshowmsg为False,当没有对应的权限时自动弹出Msgbox框)
'           con:ADODB.Connection对象
'           chrsid:功能系统号
'           chrname:用户号
'           chrauthid:功能码(可选)
'           chrauthname:功能名称(可选)
'若参数chrauthname为空时,直接检查chrauthid;若chrauthname不为空时调用getchauid()函数取得chrauthid

Public Function checkpermission(ByVal chrsid As String, ByVal chrname As String, Optional chrAuthID As String = "", Optional chrauthname As String = "", Optional blnshowmsg As Boolean = False) As Boolean
    Dim strql As String
    Dim cmd As ADODB.Command
    Dim s As String
    Dim rs As New ADODB.Recordset
    Dim RsTemp As New ADODB.Recordset
    On Error GoTo err
'    If con.State = adStateClosed Then
'        con.Open strCN
'    ElseIf con.State <> adStateOpen Then
'        con.Close
'        con.Open strCN
'    End If
    checkpermission = False
    
    '检查是否系统组成员
    'strql = "select count(*) from tau_usergroup where chrsid=" & "'" & chrsid & "'" & " and chrusername=" & "'" & chrname & "'" & " and chrgroupname ='" & gchrAdmin & "'"
    strql = "select * from tau_usergroup where chrusername=" & "'" & chrname & "'" & " and chrgroupname ='system'"
    Set rs = cN.Execute(strql, , 1)
    If Not rs.EOF Then
        checkpermission = False  '系统组成员只能赋予别人权限，不能帐务处理
        If Not blnshowmsg Then MsgBox "系统管理员只能授予别人权限，不能进入系统工作。", vbCritical, "警告"
        Exit Function
    End If
    Set rs = Nothing
    
    '从功能名称获取功能号
    If chrauthname <> "" Then
        ' lzw remark chrauthid = find_authid(con, chrsid, chrauthname)
        chrAuthID = FindAuth(chrsid, chrauthname)
        If InStr(1, chrAuthID, "@") Then
            If Not blnshowmsg Then MsgBox "功能号重复", vbApplicationModal, "权限判断"
            Exit Function
        End If
        If chrAuthID = "" Then
            If Not blnshowmsg Then MsgBox "对不起，你没有使用""" & chrauthname & """的权限!" & Chr(13) & Chr(13) & "请与系统管理员联系...", vbApplicationModal, "权限判断"
            checkpermission = False
            Exit Function
        End If
    End If
    
    '检查用户是否有权限
    strql = "select chrauthid from tau_userauth where chrsid=" & "'" & chrsid & "'" & " and chrusername=" & "'" & chrname & "'" & " and chrauthid like" & "'_" & chrAuthID & "'"
    Set rs = cN.Execute(strql, , 1)
    If Not rs.EOF Then
        If Mid(rs.Fields(0).Value, 1, 1) = "+" Then
            checkpermission = True
        Else
            checkpermission = False
            If Not blnshowmsg Then Call AuthIDtoStr(cN, chrAuthID)
        End If
        Exit Function
    End If
    Set rs = Nothing
    
    '检查用户所属组的权限
    strql = "select chrgroupname from tau_usergroup where chrusername=" & "'" & chrname & "'"
    Set rs = cN.Execute(strql, , 1)
    While Not rs.EOF
        'strql = "select count(*) from tau_groupauth where chrsid=" & "'" & chrsid & "'" & " and chrgroupname=" & "'" & rs.Fields(0).Value & "'" & " and chrauthid=" & "'" & chrauthid & "'"
        strql = "select * from tau_groupauth where chrsid=" & "'" & chrsid & "'" & " and chrgroupname=" & "'" & rs.Fields(0).Value & "'" & " and chrauthid=" & "'" & chrAuthID & "'"
        Set RsTemp = cN.Execute(strql, , 1)
        If Not RsTemp.EOF Then
            checkpermission = True
            Exit Function
        Else
            checkpermission = False
            If Not blnshowmsg Then Call AuthIDtoStr(cN, chrAuthID)
            Exit Function
        End If
        rs.MoveNext
    Wend
    If Not blnshowmsg Then Call AuthIDtoStr(cN, chrAuthID)   ' lzw 2002-06-27 增加条件限制
    Set rs = Nothing
    Set RsTemp = Nothing
    Exit Function
err:
    MsgBox "权限检验出错：" & err.Description
    checkpermission = False
End Function


'检查用户权限
'           StrSys所用系统名
'           chrsid:功能系统编号(如"system")
'           chrname:用户号(不是用户名)
'           chrauthid:功能码(可选)
'           chrauthname:功能名称(可选)
'若参数chrauthname为空时,直接检查chrauthid;若chrauthname不为空时调用
'getchauid()函数取得chrauthid

'Public Function CheckPermission2(ByVal StrSys As String, ByVal chrsid As String, ByVal chrname As String, _
'    Optional chrAuthID As String = "", Optional chrauthname As String = "") As Boolean
'    Dim strql As String
'    Dim cmd As ADODB.Command
'    Dim s As String
'    Dim rs As New ADODB.Recordset
'    Dim RsTemp As New ADODB.Recordset
'    On Error GoTo Err
'
'    ' remark
''    If cn.State <> adStateClosed Then    '建立连接
''       cn.Close
''    End If
''    cn.ConnectionString = GetDBConnect(StrSys)      '与索引数据库重新建立链接
''    cn.CursorLocation = adUseClient     '指定为客户端用户
''    cn.CommandTimeout = 0
''    cn.Open
'
'
'    '检查是否系统组成员
'    'strql = "select count(*) from tau_usergroup where chrsid=" & "'" & chrsid & "'" & " and chrusername=" & "'" & chrname & "'" & " and chrgroupname ='" & gchrAdmin & "'"
'    strql = "select * from tau_usergroup where chrusername=" & "'" & chrname & "'" & " and chrgroupname ='system'"
'    Set rs = cN.Execute(strql, , 1)
'    If Not rs.EOF Then
'        checkpermission = False  '系统组成员只能赋予别人权限，不能操作
'        Exit Function
'    End If
'    Set rs = Nothing
'
'    '从功能名称获取功能号
'    If chrauthname <> "" Then
'        ' chrauthid = find_authid(cn, chrsid, chrauthname) remark
'        chrAuthID = FindAuth(chrsid, chrauthname)
'        If InStr(1, chrAuthID, "@") Then
'            '功能号重复
'            checkpermission = False
'            Exit Function
'        End If
'        If chrAuthID = "" Then
'            checkpermission = False
'            Exit Function
'        End If
'    End If
'
'    '检查用户是否有权限
'    strql = "select chrauthid from tau_userauth where chrsid=" & "'" & chrsid & "'" & " and chrusername=" & "'" & chrname & "'" & " and chrauthid like" & "'_" & chrAuthID & "'"
'    Set rs = cN.Execute(strql, , 1)
'    If Not rs.EOF Then
'        If Mid(rs.Fields(0).Value, 1, 1) = "+" Then
'            checkpermission = True
'        Else
'            checkpermission = False
'
'        End If
'        Exit Function
'    End If
'    Set rs = Nothing
'
'    '检查用户所属组是否有权限
'    strql = "select chrgroupname from tau_usergroup where chrusername=" & "'" & chrname & "'"
'    Set rs = cN.Execute(strql, , 1)
'    While Not rs.EOF
'        'strql = "select count(*) from tau_groupauth where chrsid=" & "'" & chrsid & "'" & " and chrgroupname=" & "'" & rs.Fields(0).Value & "'" & " and chrauthid=" & "'" & chrauthid & "'"
'        strql = "select * from tau_groupauth where chrsid=" & "'" & chrsid & "'" & " and chrgroupname=" & "'" & rs.Fields(0).Value & "'" & " and chrauthid=" & "'" & chrAuthID & "'"
'        Set RsTemp = cN.Execute(strql, , 1)
'        If Not RsTemp.EOF Then
'            checkpermission = True
'            Exit Function
'        Else
'            checkpermission = False
'
'            Exit Function
'        End If
'        rs.MoveNext
'    Wend
'
'    Set rs = Nothing
'    Set RsTemp = Nothing
'    Exit Function
'Err:
'
'    checkpermission = False
'End Function


' 功能管理：根据功能名称转换成功能代号。
' LZW 2002-03
Public Function FindAuth(ByVal SysName As String, AuthName As String) As String
    Dim intPos As Integer
    Dim strResult As String
    Dim strSQL As String, strLeftName As String, strRightName As String
    Dim strAuthID1 As String, strAuthID2 As String
    Dim strLeftID As String, strRightID As String
    Dim intLeftPos As Integer, intRightPos As Integer
    
    Dim st As ADODB.Recordset

    FindAuth = ""

    intPos = InStrRev(AuthName, ".")
    If intPos = 0 Then                            ' 功能名是否有"."
        strSQL = "select chrauthid from tau_auth where chrauth='" & AuthName _
            & "' and chrsid='" & SysName & "'"
        Set st = cN.Execute(strSQL)
        Do While Not st.EOF
            If FindAuth = "" Then
                FindAuth = st("chrauthid")
            Else: FindAuth = FindAuth & "@" & st("chrauthid")
            End If
            st.MoveNext
        Loop

       Exit Function
    End If

    strLeftName = Left(AuthName, intPos - 1)
    strRightName = Mid(AuthName, intPos + 1)

    strAuthID1 = FindAuth(SysName, strLeftName) & "@"
    strAuthID2 = FindAuth(SysName, strRightName) & "@"

    If strAuthID1 = "@" Or strAuthID2 = "@" Then Return

    intLeftPos = 1
    Do While 2 > 0
        intPos = InStr(intLeftPos, strAuthID1, "@")
        If intPos = 0 Then Exit Do
        strLeftID = Mid(strAuthID1, intLeftPos, intPos - intLeftPos)
        intLeftPos = intPos + 1
        intRightPos = 1
        Do While 2 > 0
            intPos = InStr(intRightPos, strAuthID2, "@")
            If intPos = 0 Then Exit Do
            strRightID = Mid(strAuthID2, intRightPos, intPos - intRightPos)
            intRightPos = intPos + 1
            If InStr(1, strRightID, strLeftID) = 1 And InStr(Len(strLeftID) + 2, strRightID, ".") = 0 Then
                ' 组合正确，生成功能代号
                If FindAuth = "" Then
                    FindAuth = strRightID
                Else
                    FindAuth = FindAuth & "@" & strRightID
                End If
            End If

        Loop
    Loop
End Function

' 根据功能号取得功能名称
Public Sub AuthIDtoStr(con As ADODB.Connection, chrAuthID As String)
    Dim rs As New ADODB.Recordset
    Dim strSQL As String
    Dim strtmp As String
    Dim i, j As Integer
    On Error GoTo err
    strtmp = ""
    For i = 0 To Len(chrAuthID)
      strSQL = "select chrauth from tau_auth where chrauthid =" & "'" & Mid(chrAuthID, 1, 3 + i * 4) & "'"
      Set rs = con.Execute(strSQL, , 1)
      If Not rs.EOF And i = 0 Then
        strtmp = Trim(rs.Fields(0).Value)
      Else
        strtmp = strtmp & "." & Trim(rs.Fields(0).Value)
      End If
      j = i * 4 + 4
      If j > Len(chrAuthID) Then Exit For
    Next i
    Set rs = Nothing
    MsgBox "对不起，你没有使用""" & strtmp & """的权限!" & Chr(13) & Chr(13) & "请与系统管理员联系...", vbApplicationModal, "权限判断"
    Exit Sub
err:
    MsgBox "权限名称读取出错：" & err.Description
End Sub


' 口令加密函数
Public Function Encrypt(sInput As String) As String
  Dim i As Integer
  Dim mLength As Integer
  Dim cc As Long
  Dim Key As Long
  Dim sResult As String
  
  sResult = ""
  Key = 3
  
  mLength = Len(sInput)
  If mLength = 0 Then
     Encrypt = "888888"
     Exit Function
  End If
  
  For i = 1 To mLength
    Key = Key + CLng(Asc(Mid(sInput, i, 1)) * CLng((i + 3)))
  Next
  If Key < 0 Then
     Key = -Key
  End If
  
  For i = 1 To 30
    If i <= mLength Then
       cc = Asc(Mid(sInput, i, 1)) - 48
       If cc < 0 Then
          cc = -cc
       End If
    Else
      cc = cc + (i + 2) * (Key \ i) + 3
    End If
    cc = (CLng(Key) * i + cc * 3 + 1) Mod 10
    sResult = sResult & CStr(cc)
Next

  Encrypt = sResult
End Function

' 检查注册码是否正确的函数。使用口令加密函数对单位名称加密，然后使用加密结果的前十位作为注册码
Public Function CheckRegCode(ByVal strName As String, strRegCode As String) As Boolean
' 禁止注册码检查 mark
        CheckRegCode = True
'    Dim strResult As String
'    strResult = Encrypt(strName)
'    If Left(strRegCode, 10) = Left(strResult, 10) Then
'        CheckRegCode = True
'    Else
'        CheckRegCode = False
'    End If
End Function


'用户登录口令检查
'           con--ADODB.Connection对象
'           strname--用户名
'           strpwd--密码
'           strsid--系统功能号

'Public Function checkuser(con As ADODB.Connection, strname As String, ByVal strpwd As String, Optional strsid As String = "") As Boolean lzw remark
Public Function checkuser(strName As String, ByVal strPWD As String, Optional strsid As String = "") As Boolean
    Dim strql As String
    Dim rs As New ADODB.Recordset
    On Error GoTo err
    checkuser = False
    strName = Trim(strName)
    strPWD = Trim(strPWD)
    If strPWD = "" Then Exit Function
    strPWD = Encrypt(strName & strPWD)
    strql = "select chrpassword,chrworknum,chrtruename,chrsingle from tau_users where chrusername='" & strName & "'"
    Set rs = cN.Execute(strql, , 1)
    If Not rs.EOF Then
        
        'strLoginUserID = strname
        'strLoginUserName = Trim(rs.Fields("chrtruename").Value)
        'strloginworknum = Trim(rs.Fields("chrworknum").Value)
        If strPWD = Mid(rs.Fields(0), 3) Then
            If strsid = "" Or rs.Fields("chrsingle") = "s" Then
                checkuser = True
'                CurrentOperatorName = Trim(rs.Fields("chrtruename").Value)  remark
                'strpwd = rs.Fields(0)
            Else
                strql = "select * from tau_usergroup where (chrsid = '" & strsid & "' and chrusername = '" & strName & "') or (chrgroupname = 'system' and chrusername = '" & strName & "')"
                Set rs = cN.Execute(strql, , 1)
                If Not rs.EOF Then checkuser = True
            End If
        End If
    End If
    Exit Function
err:
    MsgBox "检查用户时出错：" & err.Description, vbCritical
End Function