frmauthoritygrp.frm

金算盘软件代码

    End If
End Sub

Private Sub Form_Activate()
    'Dim vntMessage As Variant
    
    '响应消息
    'For Each vntMessage In mclsMainControl.Messages
    '    If vntMessage = Message.msgAuthorityChanged Then '接收到改变权限消息
            'mclsMainControl_ToolRefresh
   '         MsgBox "放更改权限代码"
   '         mclsMainControl.Messages.Remove CStr(vntMessage) '清除改变权限消息
   '     End If
   ' Next
   ' mclsMainControl.Messages.Clear
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyEscape Then
        If treModule.SelectedItem.Key = "CNewNode" Then
            treModule.SelectedItem.Text = "     "
'            ShowMsg hwnd, "权限组名不能为空,本次增加无效!", vbExclamation, Me.Caption
            treModule.Nodes.Remove "CNewNode"
        End If
    End If
End Sub

Private Sub Form_Load()
    Dim Strsql As String
     
    SetHelpID hwnd, 11009
    Utility.LoadFormResPicture Me
   
    mlngGroupID = 0
    mblnIsChanged = False
    InitModuleRightGroupTree
    
    RefreshButton
End Sub

Private Sub InitModuleRightGroupTree()
    Dim recModuleRight As Recordset, Strsql As String
    
    treModule.Nodes.Clear
    Strsql = "SELECT Module.lngModuleID AS mID,Module.strModuleName AS mName," _
        & "RightGroup.lngRightGroupID AS gID,RightGroup.strRightGroupName AS " _
        & "gName FROM Module LEFT JOIN RightGroup ON Module.lngModuleID=" _
        & "RightGroup.lngModuleID ORDER BY Module.lngModuleID," _
        & "RightGroup.lngRightGroupID"
    Set recModuleRight = gclsBase.BaseDB.OpenRecordset(Strsql, dbOpenForwardOnly)
    
    Dim lngMID As Long
    With recModuleRight
    lngMID = !Mid
    treModule.Nodes.Add , , "R" & !Mid, !MName, "Close"
    Do Until .EOF
        If lngMID = !Mid Then
            If Not IsNull(!gID) Then
                treModule.Nodes.Add "R" & !Mid, tvwChild, "C" & !gID, !gName, _
                    "Leaf", "Sele"
            End If
            .MoveNext
        Else
            lngMID = !Mid
            treModule.Nodes.Add , , "R" & !Mid, !MName, "Close"
        End If
    Loop
    End With
    
End Sub

Private Sub InitRightArray(ModuleID As Long, GroupID As Long)
    Dim recModuleRight As Recordset, recGroupRight As Recordset
    Dim i As Integer
    
    i = 0
    gclsBase.BaseDB.QueryDefs("SelectRightQuery").Parameters("ModuleID") = ModuleID
    gclsBase.BaseDB.QueryDefs("SelectRightQuery").Parameters("GroupID") = GroupID
    Set recModuleRight = gclsBase.BaseDB.QueryDefs("SelectRightQuery").OpenRecordset(dbOpenSnapshot)
    If Not recModuleRight.EOF Then
        recModuleRight.MoveLast
        recModuleRight.MoveFirst
        i = recModuleRight.RecordCount
    End If

    gclsBase.BaseDB.QueryDefs("SelectedRightQuery").Parameters("GroupID") = GroupID
    Set recGroupRight = gclsBase.BaseDB.QueryDefs("SelectedRightQuery").OpenRecordset(dbOpenSnapshot)
    If Not recGroupRight.EOF Then
        recGroupRight.MoveLast
        recGroupRight.MoveFirst
        i = i + recGroupRight.RecordCount
    End If
    ReDim maryRight(i)
    i = 0
    Do Until recModuleRight.EOF
        maryRight(i).RightID = recModuleRight!rID
        maryRight(i).RightName = recModuleRight!rName
        maryRight(i).Range = recModuleRight!blnRange
        maryRight(i).RightRange = 0
        maryRight(i).inSelected = False
        maryRight(i).fiSelected = False
        i = i + 1
        recModuleRight.MoveNext
    Loop
    recModuleRight.Close
    Do Until recGroupRight.EOF
        maryRight(i).RightID = recGroupRight!rID
        maryRight(i).RightName = recGroupRight!rName
        maryRight(i).Range = recGroupRight!blnRange
        maryRight(i).RightRange = recGroupRight!bytrange
        maryRight(i).inSelected = True
        maryRight(i).fiSelected = True
        i = i + 1
        recGroupRight.MoveNext
    Loop
    recGroupRight.Close
End Sub

Private Sub Form_Paint()
    FrameBox Me.hwnd, 100, 250, 2050, 4000
    FrameBox Me.hwnd, 2200, 250, 7300, 4000
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If mblnIsChanged Then UpdateData
    Utility.UnLoadFormResPicture Me
    mblnIsChanged = False
End Sub

Private Sub lstAll_Click()
    RefreshButton
End Sub

Private Sub lstAll_DblClick()
    If mlngGroupID > 10 Then cmdSel_Click 0
End Sub

Private Sub lstSelected_Click()
    Dim i As Integer
    
    i = lstSelected.ItemData(lstSelected.ListIndex)
    
    If maryRight(i).Range Then
        Frame3.Visible = True
        optRange(0).Visible = True
        optRange(1).Visible = True
        optRange(2).Visible = True
        lstAll.Height = 2040
        lstSelected.Height = lstAll.Height
        cmdSel(1).top = 1130
        cmdSel(2).top = 1630
        cmdSel(3).top = 2130
        optRange(maryRight(i).RightRange).Value = True
        Frame3.Caption = lstSelected.Text & "的作用范围(&R)"
        If mlngGroupID < 11 Then
            Frame3.Enabled = False
            optRange(0).Enabled = False
            optRange(1).Enabled = False
            optRange(2).Enabled = False
        Else
            Frame3.Enabled = True
            optRange(0).Enabled = True
            optRange(1).Enabled = True
            optRange(2).Enabled = True
        End If
        If maryRight(i).RightID = 29 And optRange(0).Enabled Then            '不能复核本人的凭证
            optRange(0).Enabled = False
            If optRange(0).Value Then optRange(1).Value = True
        End If
    Else
        Frame3.Visible = False
        lstAll.Height = 3120
        cmdSel(1).top = 1558
        cmdSel(2).top = 2486
        cmdSel(3).top = 3414
        lstSelected.Height = lstAll.Height
    End If
    RefreshButton
End Sub

Private Sub lstSelected_DblClick()
    If mlngGroupID > 10 Then cmdSel_Click 2
End Sub

Public Sub RefreshButton()

    If mlngGroupID < 11 Then              '系统给MANAGER预置的权限组，不允许编辑
        cmdSel(0).Enabled = False
        cmdSel(1).Enabled = False
        cmdSel(2).Enabled = False
        cmdSel(3).Enabled = False
    Else
        If lstAll.ListCount = 0 Then
            cmdSel(1).Enabled = False
        Else
            cmdSel(1).Enabled = True
        End If
        If lstAll.ListIndex = -1 Then
            cmdSel(0).Enabled = False
        Else
            cmdSel(0).Enabled = True
        End If
    
        If lstSelected.ListCount = 0 Then
            cmdSel(3).Enabled = False
        Else
            cmdSel(3).Enabled = True
        End If
        If lstSelected.ListIndex = -1 Then
            cmdSel(2).Enabled = False
        Else
            cmdSel(2).Enabled = True
        End If
    End If
End Sub

Private Sub optRange_Click(Index As Integer)
    maryRight(lstSelected.ItemData(lstSelected.ListIndex)).RightRange = Index
    mblnIsChanged = True
End Sub

Private Sub treModule_AfterLabelEdit(Cancel As Integer, NewString As String)
    Dim NodX As Node, Strsql As String
    
    If Trim$(NewString) = "" Then
        If treModule.SelectedItem.Key = "CNewNode" Then
            treModule.SelectedItem.Text = NewString
            ShowMsg hwnd, "权限组名不能为空,本次增加无效!", vbExclamation, Me.Caption
            treModule.Nodes.Remove "CNewNode"
        Else
            ShowMsg hwnd, "权限组名不能为空!", vbExclamation, Me.Caption
        End If
        treModule.StartLabelEdit
        Cancel = True
        Exit Sub
    End If
    If strLen(NewString) > 30 Then
        If treModule.SelectedItem.Key = "CNewNode" Then
            treModule.SelectedItem.Text = NewString
            ShowMsg hwnd, "权限组名太长,本次增加无效!", vbExclamation, Me.Caption
            treModule.Nodes.Remove "CNewNode"
        Else
            ShowMsg hwnd, "权限组名太长,请重新命名!", vbExclamation, Me.Caption
        End If
        Cancel = True
        Exit Sub
    End If
    If ContainErrorChar(NewString) Then
        If treModule.SelectedItem.Key = "CNewNode" Then
            treModule.SelectedItem.Text = NewString
            ShowMsg hwnd, "权限组名包括非法字符,本次增加无效!", vbExclamation, Me.Caption
            treModule.Nodes.Remove "CNewNode"
        Else
            ShowMsg hwnd, "权限组名包括非法字符,请重新命名!", vbExclamation, Me.Caption
        End If
        Cancel = True
        Exit Sub
    End If
    For Each NodX In treModule.Nodes
        If NodX.Key <> treModule.SelectedItem.Key Then
            If NodX.Text = NewString Then
                If treModule.SelectedItem.Key = "CNewNode" Then
                    treModule.SelectedItem.Text = NewString
                    MsgBox "已有同名的权限组存在,本次增加无效!", vbExclamation, Me.Caption
                    treModule.Nodes.Remove "CNewNode"
                Else
                    MsgBox "已有同名的权限组存在,请重新命名!", vbExclamation, Me.Caption
                End If
                Cancel = True
                Exit Sub
            End If
        End If
    Next NodX
    If treModule.SelectedItem.Key = "CNewNode" Then
        Strsql = "INSERT INTO RightGroup (strRightGroupName,lngModuleID) VALUES" _
            & "('" & NewString & "'," & Mid$(treModule.SelectedItem.Parent.Key, 2) _
            & ")"
        gclsBase.BaseDB.Execute Strsql
        Dim recRG As Recordset
        
        Strsql = "SELECT lngRightGroupID FROM RightGroup WHERE strRightGroupName='" _
            & NewString & "'"
        Set recRG = gclsBase.BaseDB.OpenRecordset(Strsql, dbOpenForwardOnly)
        treModule.SelectedItem.Key = "C" & recRG!lngRightGroupID
    Else
        Strsql = "UPDATE RightGroup SET strRightGroupName='" & NewString _
            & "' WHERE lngRightGroupID=" & Mid$(treModule.SelectedItem.Key, 2)
        gclsBase.BaseDB.Execute Strsql
    End If
    treModule_NodeClick treModule.SelectedItem
End Sub

Private Sub treModule_BeforeLabelEdit(Cancel As Integer)
    If Left$(treModule.SelectedItem.Key, 1) <> "C" Then Cancel = True
End Sub

Private Sub treModule_Collapse(ByVal Node As ComctlLib.Node)
    Node.Image = "Close"
    treModule_NodeClick Node
End Sub

Private Sub treModule_Expand(ByVal Node As ComctlLib.Node)
    Node.Image = "Open"
    treModule_NodeClick Node
End Sub

Private Sub treModule_NodeClick(ByVal Node As ComctlLib.Node)
    Dim i As Integer
'    Static blnNInit As Boolean
    
    If mblnIsChanged Then
        UpdateData
        mblnIsChanged = False
    End If
    Frame3.Visible = False
    lstAll.Height = 3120
    lstSelected.Height = lstAll.Height
    cmdSel(1).top = 1558
    cmdSel(2).top = 2486
    cmdSel(3).top = 3414
    If Left$(Node.Key, 1) <> "C" Then
        lstAll.Clear
        lstSelected.Clear
        mlngGroupID = 0
        CmdRight(0).Enabled = False
        CmdRight(1).Enabled = True
        CmdRight(2).Enabled = False
    ElseIf mlngGroupID <> Mid$(Node.Key, 2) Then
        CmdRight(0).Enabled = True
        CmdRight(1).Enabled = False
        CmdRight(2).Enabled = True
'        CmdRight(2).Enabled = (Mid$(Node.Key, 2) > "10")
'        If blnNInit Then UpdateData
'        blnNInit = True
        mlngGroupID = Mid$(Node.Key, 2)
        InitRightArray Mid$(Node.Parent.Key, 2), mlngGroupID
        lstAll.Clear
        lstSelected.Clear
        If UBound(maryRight, 1) < 0 Then Exit Sub
        For i = 0 To UBound(maryRight) - 1
            If maryRight(i).inSelected Then
                lstSelected.AddItem maryRight(i).RightName
                lstSelected.ItemData(lstSelected.NewIndex) = i
            Else
                lstAll.AddItem maryRight(i).RightName
                lstAll.ItemData(lstAll.NewIndex) = i
            End If
        Next i
    End If
    If Node.Key = "C1" Then
        CmdRight(0).Enabled = False
        CmdRight(1).Enabled = False
        CmdRight(2).Enabled = False
    End If
    If lstAll.ListCount > 0 Then lstAll.ListIndex = 0
'    Set treModule.DropHighlight = Node
    RefreshButton
End Sub

Private Sub UpdateData()
    Dim i As Integer, Strsql As String
    
    For i = 0 To UBound(maryRight)
        If Not maryRight(i).inSelected And maryRight(i).fiSelected Then
            Strsql = "INSERT INTO RightGroupDetail VALUES(" & mlngGroupID _
                & "," & maryRight(i).RightID & "," & maryRight(i).RightRange & ")"
        ElseIf maryRight(i).inSelected And Not maryRight(i).fiSelected Then
            Strsql = "DELETE FROM RightGroupDetail WHERE lngRightGroupID=" _
                & mlngGroupID & " AND lngRightID=" & maryRight(i).RightID
        ElseIf maryRight(i).inSelected And maryRight(i).fiSelected Then
            Strsql = "UPDATE RightGroupDetail SET bytRange=" _
                & maryRight(i).RightRange & " WHERE lngRightGroupID=" _
                & mlngGroupID & " AND lngRightID=" & maryRight(i).RightID
        Else
            Strsql = ""
        End If
        If Strsql <> "" Then gclsBase.BaseDB.Execute Strsql
    Next i
End Sub

Public Sub EditAutherGrp(Grp As String)
    'treModule.SelectedItem = treModule.Nodes(Grp)
    treModule_NodeClick treModule.Nodes(1)
    Show vbModal
'    Refresh
'    ZOrder 0
End Sub