mdllogin.bas

一个把自己的东西刻成光盘后自动查询和启动的原代码

Attribute VB_Name = "MdlLogin"

'######################################################################
'清除用户信息
'######################################################################
Public Sub Clear_User_Info(p_User_Info As User_Info)
With p_User_Info
   .Branch_ID = 0
   .Department_ID = 0
   .Level_ID = 0
   .Lock_Status = 0
   .Login_Name = ""
   .Password = ""
   .Retry_Time = 0
   .User_ID = 0
   .User_Name = ""
   .Expire_Time = Date
End With
End Sub

'######################################################################
'用户退录函数LogOut
'参数：p_Login_Name退录用户名 p_User_ID 退录用户ID
'返回值：Boolean
'######################################################################
Public Function LogOut(p_Login_Name As String, p_User_ID As Integer) As Boolean
On Error GoTo Err
LogOut = True
Exit Function
Err:
   LogOut = False
End Function

'######################################################################
'用户登录函数Login
'参数：p_Login_Name登录用户名 p_PWD登录用户密码
'返回值：p_Rtn_String返回描述 p_User_Info返回用户结构
'函数返回：1 登录成功 非1登录失败 2  操作员被锁定   3   口令不正确
'4  3次不正确，锁定   5  操作员不存在 6 系统无操作员 7操作员正在使用中 8操作员过期
'######################################################################
Public Function Login(p_Login_Name As String, p_PWD As String, _
                p_Rtn_String As String, p_User_Info As User_Info) As Integer

On Error GoTo Err
Dim t_Rtn_Code As Integer '函数返回值

p_Rtn_String = ""
Call Clear_User_Info(p_User_Info)

If p_PWD <> "8888" Then
   p_Rtn_String = "您输入的口令不正确，请重新输入"
   Login = 3
   GoTo Err
End If

With p_User_Info
   .Login_Name = p_Login_Name
   .Password = p_PWD
End With
Login = 1 '成功登录

Exit Function
Err:
   If Login = 0 Then p_Rtn_String = "用户登录时出错，请与管理员联系"
End Function

'######################################################################
'用户操作权限认证函数
'参数：p_User_ID须认证的用户ID p_Operate_Code 认证的操作代码
'函数返回：Boolean 是否通过
'######################################################################
Public Function Check_Operate_Permission(p_User_ID As String, p_Operate_Code As String) As Boolean
On Error GoTo Err
Dim tSql As String
tSql = "select distinct(role_right.operate_code) from user_role,role_right " & _
       "where user_role.role_id = role_right.role_id and " & _
       "user_role.user_id=" + p_User_ID + " and role_right.operate_code='" + p_Operate_Code + "'"
Set gRst = gDbs.OpenRecordset(tSql)
If gRst.EOF Then GoTo Err
Check_Operate_Permission = True
Exit Function
Err:
   Check_Operate_Permission = False
End Function

'######################################################################
'文件访问权限认证函数
'参数：p_User_Info须认证的用户结构 pFileID 认证的文件ID pTypeCode认证的文件档案类型
'函数返回：boolean
'         r_rights 0无权限 1查看 2打印 3无文件
'         若此参数初始值为1或2时函数验证是否有相应权限，返回值为boolean 否则函数返回具有的最高权限r_rights
'         r_Effective_Time 生效时间 r_Expire_Time 失效时间 可以为空
'         p_Query_Date 查询的日期
'######################################################################
Public Function Check_File_Permission(p_User_Info As User_Info, pFileID As String, pTypeCode As String, _
       p_Query_Date As Date, r_Effective_Time As String, r_Expire_Time As String, r_Rights As Integer) As Boolean
On Error GoTo Err

Dim t_Rights As Integer '当前的最高权限 0无权限 1查看 2打印 3无文件
Dim tSql As String
Dim tSql1, tSql2, tSql3 As String

Dim a(3, 2) As String


r_Effective_Time = ""
r_Expire_Time = ""
Check_File_Permission = False

'查看文件默认权限
t_Rights = Check_File_Default_Permission(p_User_Info, pFileID, pTypeCode)
If IsDate(p_Query_Date) = False Then GoTo Err

If t_Rights = 2 Then '已经具有最高权限
   Check_File_Permission = True
   r_Rights = 2
   Exit Function
ElseIf t_Rights = 3 Then '没有此文件
   Check_File_Permission = False
   r_Rights = 0
   Exit Function
End If
   
If r_Rights <> 0 Then '检查是否具有所传参数的权限
   tSql2 = " and rights>=" + CStr(r_Rights) + " "
   tSql3 = " and a.rights>=" + CStr(r_Rights) + " "
Else '检查最高权限
   tSql2 = " "
   tSql3 = " "
End If

'时间期限条件子句
tSql1 = "to_date('" + Format(p_Query_Date, "yyyy-mm-dd") + "','yyyy-mm-dd')"
tSql1 = " and effective_time is null or (effective_time<" + tSql1 + " and (expire_time>" + tSql1 + " or expire_time is null) "

'检查部门
tSql = "select * from file_right where type_code='" + pTypeCode + "' and " & _
       "file_id=" + pFileID + " and type=2 and object_id=" + CStr(p_User_Info.Department_ID) & _
       tSql1 + tSql2 + " order by rights desc"
Set gRst = gDbs.OpenRecordset(tSql)
If Not gRst.EOF Then
   t_Rights = gRst.Fields("rights")
   If r_Rights <> 0 And t_Rights >= r_Rights Then '检查是否具有所传参数的权限
      r_Rights = t_Rights
      Check_File_Permission = True
      If IsDate(gRst.Fields("effective_time")) Then r_Effective_Time = Format(gRst.Fields("effective_time"), "yyyy-mm-dd")
      If IsDate(gRst.Fields("expire_time")) Then r_Expire_Time = Format(gRst.Fields("expire_time"), "yyyy-mm-dd")
      Exit Function
   ElseIf r_Rights = 0 Then '检查最高权限
      If r_Rights < t_Rights Then
         r_Rights = t_Rights
         If IsDate(gRst.Fields("effective_time")) Then r_Effective_Time = Format(gRst.Fields("effective_time"), "yyyy-mm-dd")
         If IsDate(gRst.Fields("expire_time")) Then r_Expire_Time = Format(gRst.Fields("expire_time"), "yyyy-mm-dd")
      End If
   End If
End If

'检查用户
tSql = "select * from file_right where type_code='" + pTypeCode + "' and " & _
       "file_id=" + pFileID + " and type=0 and object_id=" + CStr(p_User_Info.User_ID) & _
       tSql1 + tSql2 + " order by rights desc"
Set gRst = gDbs.OpenRecordset(tSql)
If Not gRst.EOF Then
   t_Rights = gRst.Fields("rights")
   If r_Rights <> 0 And t_Rights >= r_Rights Then '检查是否具有所传参数的权限
      r_Rights = t_Rights
      Check_File_Permission = True
      If IsDate(gRst.Fields("effective_time")) Then r_Effective_Time = Format(gRst.Fields("effective_time"), "yyyy-mm-dd")
      If IsDate(gRst.Fields("expire_time")) Then r_Expire_Time = Format(gRst.Fields("expire_time"), "yyyy-mm-dd")
      Exit Function
   ElseIf r_Rights = 0 Then '检查最高权限
      If r_Rights < t_Rights Then
         If IsDate(gRst.Fields("effective_time")) Then r_Effective_Time = Format(gRst.Fields("effective_time"), "yyyy-mm-dd")
         If IsDate(gRst.Fields("expire_time")) Then r_Expire_Time = Format(gRst.Fields("expire_time"), "yyyy-mm-dd")
      End If
   End If
End If

'检查级别
tSql = "select * from file_right where type_code='" + pTypeCode + "' and " & _
       "file_id=" + pFileID + " and type=3 and object_id=" + CStr(p_User_Info.Level_ID) & _
       tSql1 + tSql2 + " order by rights desc"
Set gRst = gDbs.OpenRecordset(tSql)
If Not gRst.EOF Then
   t_Rights = gRst.Fields("rights")
   If r_Rights <> 0 And t_Rights >= r_Rights Then '检查是否具有所传参数的权限
      r_Rights = t_Rights
      Check_File_Permission = True
      If IsDate(gRst.Fields("effective_time")) Then r_Effective_Time = Format(gRst.Fields("effective_time"), "yyyy-mm-dd")
      If IsDate(gRst.Fields("expire_time")) Then r_Expire_Time = Format(gRst.Fields("expire_time"), "yyyy-mm-dd")
      Exit Function
   ElseIf r_Rights = 0 Then '检查最高权限
      If r_Rights < t_Rights Then
         If IsDate(gRst.Fields("effective_time")) Then r_Effective_Time = Format(gRst.Fields("effective_time"), "yyyy-mm-dd")
         If IsDate(gRst.Fields("expire_time")) Then r_Expire_Time = Format(gRst.Fields("expire_time"), "yyyy-mm-dd")
      End If
   End If
End If

'时间期限条件子句
tSql1 = "to_date('" + Format(p_Query_Date, "yyyy-mm-dd") + "','yyyy-mm-dd')"
tSql1 = " and a.effective_time is null or (a.effective_time<" + tSql1 + " and (a.expire_time>" + tSql1 + " or a.expire_time is null) "

'检查角色
tSql = "select a.rights,a.effective_time,a.expire_time from file_right a," & _
     "(select  distinct(role_id) as role_id from user_role where user_id=" + CStr(p_User_Info.User_ID) + ")  b " & _
     "where a.object_id=b.role_id and a.type=1 " + tSql1 + tSql3 + " order by a.rights desc"
Set gRst = gDbs.OpenRecordset(tSql)
If Not gRst.EOF Then
   t_Rights = gRst.Fields("rights")
   If r_Rights <> 0 And t_Rights >= r_Rights Then '检查是否具有所传参数的权限
      r_Rights = t_Rights
      Check_File_Permission = True
      If IsDate(gRst.Fields("effective_time")) Then r_Effective_Time = Format(gRst.Fields("effective_time"), "yyyy-mm-dd")
      If IsDate(gRst.Fields("expire_time")) Then r_Expire_Time = Format(gRst.Fields("expire_time"), "yyyy-mm-dd")
      Exit Function
   ElseIf r_Rights = 0 Then '检查最高权限
      If r_Rights < t_Rights Then
         If IsDate(gRst.Fields("effective_time")) Then r_Effective_Time = Format(gRst.Fields("effective_time"), "yyyy-mm-dd")
         If IsDate(gRst.Fields("expire_time")) Then r_Expire_Time = Format(gRst.Fields("expire_time"), "yyyy-mm-dd")
      End If
   End If
End If

If r_Rights = 0 Then
   Check_File_Permission = False
Else
   Check_File_Permission = True
End If
Exit Function

Err:
   Check_File_Permission = False
End Function

'######################################################################
'文件访问默认权限认证函数
'参数：p_User_Info须认证的用户结构 pFileID 认证的文件ID pTypeCode认证的文件档案类型
'函数返回：0无权限 1查看 2打印 3无文件
'######################################################################
Public Function Check_File_Default_Permission(p_User_Info As User_Info, _
                pFileID As String, pTypeCode As String) As Integer
On Error GoTo Err

Dim tSql As String

tSql = "select * from file_" + pTypeCode + " where file_id=" + pFileID
Set gRst = gDbs.OpenRecordset(tSql)
If gRst.EOF Then
   Check_File_Default_Permission = 3
   Exit Function
End If

With p_User_Info
      
Select Case UCase(pTypeCode)
 Case "WENSHU"
   '分行行级可阅可打印
   If .Branch_ID = 1001 And .Level_ID < 1001 Then   '分行行级
      Check_File_Default_Permission = 2
      Exit Function
   End If
   
   '主办部门处级可阅可打印
   If .Department_ID = gRst.Fields("department_id") And _
      .Branch_ID = gRst.Fields("branch_id") And .Level_ID < "2001" Then
      Check_File_Default_Permission = 2
      Exit Function
   End If
   
   '分行科级可阅总行发文，按主办部门控制
   If .Branch_ID = 1001 And .Level_ID < "3001" And .Branch_ID = gRst.Fields("branch_id") Then
      Check_File_Default_Permission = 1
      Exit Function
   End If
 Case Else
   Check_File_Default_Permission = 0
 
End Select

End With

Check_File_Default_Permission = True
Exit Function
Err:
   Check_File_Default_Permission = 0
End Function

'des加密算法
Public Function Des(ByVal s_s As String, ByVal i_i As Long, ByVal flg As Integer) As String
On Error GoTo Err

Dim Result, r As String
Dim tempinkey As String * 8

Dim bufout(0 To 63), kwork(0 To 55), worka(0 To 47), kn(0 To 47), buffer(0 To 63), key(0 To 63), _
    Shift(0 To 15), Binary(0 To 63), nbrofshift, temp1, temp2 As Byte
Dim valindex As Integer
Dim i, j, k, iter As Integer

Dim ss
Static s1(0 To 3, 0 To 15), s2(0 To 3, 0 To 15), s3(0 To 3, 0 To 15), s4(0 To 3, 0 To 15), _
       s5(0 To 3, 0 To 15), s6(0 To 3, 0 To 15), s7(0 To 3, 0 To 15), s8(0 To 3, 0 To 15) As Byte


'  INITIALIZE THE SOURCE,DEST,INKEY
   tempinkey = dd(i_i * 23 Mod 65536)

   For i = 0 To 7
     inkey(i) = Asc(Mid(tempinkey, i + 1, 1))
   Next i

   For i = 1 To Len(s_s)
     source(i - 1) = Asc(Mid(s_s, i, 1))
   Next i
   For i = Len(s_s) To 7
     source(i) = 0
   Next i

   For i = 0 To 7
     dest(i) = 0
   Next i


'        /* INITIALIZE THE TABLES */