frmuserauth.frm

一个用VB写的财务软件源码

        glo.frmProg.ShowProgress 10 + i / UBound(m_aryLoad) * 80
    Next i
    
    glo.frmProg.ShowProgress 90
    glo.frmProg.SetMsg "正在导入操作员目录..."
    
    With lvwUser
        .View = lvwReport
        With .ColumnHeaders
            .Add , , "代号", 800
            .Add , , "姓名", 1000
            .Add , , "性质", 2000
            .Add
        End With
        Set rSt = New ADODB.Recordset
        rSt.Open "select * from tSYS_User where titype=2 order by userID", _
                    gloSys.cnnSys, adOpenStatic, adLockReadOnly
        If rSt.RecordCount <> 0 Then
            With .ListItems
                Do Until rSt.EOF
                    Set ItmX = .Add(, , rSt.Fields("userID").Value)
                    ItmX.SubItems(1) = rSt.Fields("userName").Value
                    ItmX.SubItems(2) = "普通人员"
                    rSt.MoveNext
                Loop
            End With
        End If
        rSt.Close
    End With
    
    glo.frmProg.ShowProgress 100
    glo.frmProg.Hide
    m_bLoad = True
End Sub


Private Sub lvwUser_ItemClick(ByVal Item As MSComctlLib.ListItem)
Dim i As Integer
If Not (Item Is Nothing) Then
'    If m_sOldUserID <> Item.text Then
        
        Me.MousePointer = vbHourglass
                
        If Item.SubItems(2) = "普通人员" Then
            tvwAuth.Enabled = True
            '*
            Call LoadAuth(Item.text)
        Else
            tvwAuth.Enabled = False
            '非“普通人员”设置所有权限选中
            'Call TravelTree_CheckAll(tvwAuth.Nodes("R"))
        End If
        Me.MousePointer = vbDefault
        
'        m_sOldUserID = Item.text
'        m_bChange = False
        
'    End If
 End If
End Sub

Private Sub mnuExit_Click()
If MsgBox("是否保存？", vbQuestion + vbYesNo, "") = vbYes Then
    If Not lvwUser.SelectedItem Is Nothing Then
        SaveAuth lvwUser.SelectedItem.text
    End If
End If
Unload Me
End Sub

Private Sub mnuSave_Click()
If Not lvwUser.SelectedItem Is Nothing Then
    SaveAuth lvwUser.SelectedItem.text
End If
End Sub


Private Sub tbr_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case UCase(Button.Key)
Case "SAVE"
    mnuSave_Click
Case "EXIT"
    mnuExit_Click
End Select
End Sub

Private Sub tvwAuth_NodeCheck(ByVal Node As MSComctlLib.Node)
Dim tNode As Node
Dim j As Integer
If Node.Checked Then
    SetCheckToChild Node, True
    Set tNode = Node.Parent
    SetCheckToParent tNode, True
Else
    Set tNode = Node.Parent
    While Not tNode Is Nothing
        tNode.Checked = False
        Set tNode = tNode.Parent
    Wend
    SetCheckToChild Node, False
End If
End Sub
'装载树表
Private Sub LoadTvw(ByVal strRoot As String)
    Dim sRoot As String
    Dim Nodx As Node, TempNode As Node
    Dim strSelfNode As String
    Dim strSelfNodeName As String
    Dim intLenOfRoot As Integer
    Dim intLenOfSelf As Integer
    Dim i As Integer
    Dim sIMG As String, sSelIMG As String
    
    sRoot = strRoot
    With m_adoRst
        If .RecordCount <> 0 Then
            .MoveFirst
            Do Until .EOF
                If .Fields("AuthID").Value Like sRoot & "*" Then
                    If .Fields("bEnd").Value Then
                        sIMG = "UnSelected"
                        sSelIMG = "Selected"
                    Else
                        sIMG = "Collapse"
                        sSelIMG = "Expand"
                    End If
                    
                    '取代码与名称。
                    strSelfNode = "k" & Trim(.Fields("AuthID").Value)
                    strSelfNodeName = Trim(.Fields("AuthID").Value) & "=" & _
                                Trim(.Fields("AuthName").Value)
                    
                    intLenOfRoot = Len(strRoot)             '有关联结点的长度
                    intLenOfSelf = Len(strSelfNode)         '本结点的长度
                    
                    If intLenOfRoot - intLenOfSelf = 0 Then         '为同级结点
                        Set Nodx = tvwAuth.Nodes.Add(strRoot, tvwNext, strSelfNode, strSelfNodeName, _
                                    sIMG, sSelIMG)
                    ElseIf intLenOfRoot - intLenOfSelf < 0 Then     '为子结点
                        Set Nodx = tvwAuth.Nodes.Add(strRoot, tvwChild, strSelfNode, strSelfNodeName, _
                                    sIMG, sSelIMG)
                    ElseIf intLenOfRoot - intLenOfSelf > 0 Then
                        Set TempNode = tvwAuth.Nodes(strRoot)
                        Do Until Len(TempNode.Key) = intLenOfSelf
                            Set TempNode = TempNode.Parent
                        Loop
                        Set Nodx = tvwAuth.Nodes.Add(TempNode.Key, tvwNext, strSelfNode, strSelfNodeName, _
                                    sIMG, sSelIMG)
                    End If
                    Nodx.Sorted = True
                    Nodx.Tag = .Fields("AuthMenuName").Value
                        '转换根结点
                    strRoot = strSelfNode
                End If
                .MoveNext
            Loop
        End If
    End With
    
End Sub

'装入一个用户的权限设置
Private Sub LoadAuth(ByVal sUserID As String)
    Dim rSt As ADODB.Recordset
    Dim i As Long
    Dim frm As New frmProgress2
    Me.MousePointer = 11
    frm.SetMsg "正在载入数据..."
    frm.Show , Me
     
    Set rSt = New ADODB.Recordset
    With rSt
        .CursorLocation = adUseClient
        .Open "select * from tSYS_UserAuth where AccountID='" & _
                m_sAccountID & "' and userID='" & sUserID & _
                "' order by AuthID", gloSys.cnnSys, adOpenStatic, adLockReadOnly
        SetCheckToChild tvwAuth.Nodes("R"), True
        If .RecordCount <> 0 Then
            '装入这个用户的权限设置
            Do Until .EOF
                If IsExitNodeInTreeView("k" + .Fields("AuthID").Value, tvwAuth) Then
                    tvwAuth.Nodes("k" & .Fields("AuthID").Value).Checked = False
                End If
                frm.pBr.Value = (frm.pBr.Value + 1) Mod frm.pBr.Max
                If (frm.pBr.Value Mod 7) = 0 Then
                    DoEvents
                End If
                .MoveNext
            Loop
        End If
        SetCheckWithChild tvwAuth.Nodes("R")
        .Close
    End With
    frm.ShowProgress 100
    Unload frm
    Me.MousePointer = 0
errorhandle:
End Sub

'保存一个用户的某一子系统的权限设置
Private Sub SaveAuth(ByVal sUserID As String)
    Dim Nodx As Node
    Dim TempNode As Node
    Dim frm As New frmProgress2
    frm.SetMsg "正在保存数据..."
    frm.Show , Me
    '先删除
    m_adoCmd.CommandText = "delete from tSYS_UserAuth where AccountID='" & _
            m_sAccountID & "' and UserID='" & sUserID & _
            "'"
    m_adoCmd.Execute
    frm.ShowProgress 5
    DoEvents
    '遍历树增加
    m_sSQL = "INSERT INTO tSYS_UserAuth(AccountID,UserID,AuthID) values('" & _
            m_sAccountID & "','" & sUserID & "','"
    For Each TempNode In tvwAuth.Nodes
        If TempNode.Checked = False And TempNode.Children = 0 Then
            m_adoCmd.CommandText = m_sSQL & Mid$(TempNode.Key, 2) & "')"
            m_adoCmd.Execute
        End If
        frm.pBr.Value = (frm.pBr.Value + 1) Mod frm.pBr.Max
        If (frm.pBr.Value Mod 7) = 0 Then
            DoEvents
        End If
    Next
    frm.ShowProgress 100
    Unload frm
End Sub

'根据账套号，取得一个账套的名称
Private Function GetAccountName(ByVal sID As String) As String
    Dim rSt As ADODB.Recordset
    
    Set rSt = New ADODB.Recordset
    With rSt
        .Open "select accountname from tSYS_Account where accountID='" & _
                Trim("" & sID) & "'", gloSys.cnnSys, adOpenStatic, adLockReadOnly
        If Not (.EOF And .BOF) Then
            GetAccountName = Trim$("" & .Fields(0).Value)
        Else
            GetAccountName = ""
        End If
        .Close
    End With
    
End Function

Private Function FindImageFromilsTvw(ByVal sKey As String) As Boolean
Dim img As ListImage
On Error GoTo Err:
Set img = ilsTvw.ListImages(sKey)
FindImageFromilsTvw = True
Exit Function
Err:
    FindImageFromilsTvw = False
End Function

'根据字节点Check的属性设置本节点的Check属性
Private Sub SetCheckWithChild(ByVal tNode As Node)
Dim oNode As Node
Dim j As Integer
If tNode Is Nothing Then Exit Sub
Set oNode = tNode.Child
j = 0
While Not oNode Is Nothing
    If oNode.Children > 0 Then
        SetCheckWithChild oNode
    End If
    If oNode.Checked = False Then
        j = j + 1
    End If
    Set oNode = oNode.Next
Wend
If j > 0 Then tNode.Checked = False
End Sub

'设置祖先节点的Check属性
Private Sub SetCheckToParent(ByVal tNode As Node, ByVal bCheck As Boolean)
Dim oNode As Node
Dim j As Integer
If tNode Is Nothing Then Exit Sub
Set oNode = tNode.Child
j = 0
While Not oNode Is Nothing
    If oNode.Checked = bCheck Then
        j = j + 1
    End If
    Set oNode = oNode.Next
Wend
If j = tNode.Children Then tNode.Checked = bCheck: SetCheckToParent tNode.Parent, bCheck
End Sub
'设置子孙节点的Check属性
Private Sub SetCheckToChild(ByVal oNode As Node, ByVal bCheck As Boolean)
Dim tNode As Node
Set tNode = oNode.Child
While Not tNode Is Nothing
    If tNode.Children > 0 Then
        SetCheckToChild tNode, bCheck
    End If
    tNode.Checked = bCheck
    Set tNode = tNode.Next
Wend
End Sub

'判断Key为关键值的节点是否在指定TreeView中
Public Function IsExitNodeInTreeView(ByVal Key As String, ByRef tVw As TreeView) As Boolean
Dim n As Node
On Error GoTo Err
    Set n = tVw.Nodes.Item(Key)
    IsExitNodeInTreeView = True
Exit Function
Err:
    IsExitNodeInTreeView = False
End Function