frmauth.frm

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

            Nodx.BackColor = vbInfoBackground

        End With
                
        For i = 1 To .Nodes.Count
            If .Nodes(i).Key <> "R" Then
                glo.frmProg.SetMsg "导入" & Mid$(.Nodes(i).text, _
                            InStr(1, .Nodes(i).text, "=") + 1) & "子系统的权限目录..."
                glo.frmProg.ShowProgress 5
                Call LoadTvw(.Nodes(i).Key)
                glo.frmProg.ShowProgress 100
            End If
        Next i
    End With
    
    With lvwAuth
        .View = lvwReport
        With .ColumnHeaders
            .Add , , "编码", 1000
            .Add , , "名称", 2000
            .Add , , "菜单", 2500
            .Add
        End With
    End With
    
    Call tvwAuth_NodeClick(tvwAuth.Nodes("R"))
    
    glo.frmProg.Hide
    
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
            i = 0
            .MoveFirst
            Do Until .EOF
                If .Fields(m_CFieldName).Value Like sRoot & "*" Then
                    If .Fields("bEnd").Value Then
                        sIMG = "UnSelected"
                        sSelIMG = "Selected"
                    Else
                        sIMG = "Collapse"
                        sSelIMG = "Expand"
                    End If
                    
                    '取代码与名称。
                    strSelfNode = "k" & Trim(.Fields(m_CFieldName).Value)
                    strSelfNodeName = Trim(.Fields(m_CFieldName).Value) & "=" & Trim(.Fields(m_NFieldName).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
                i = i + 1
                glo.frmProg.ShowProgress Int(i / .RecordCount * 100)
            Loop
        End If
    End With
    
End Sub




Private Sub mnuTvwAppend_Click()
    Dim frmA As frmAuthOne
    Dim adoCmd As ADODB.Command
    Dim Nodx As Node
    
    On Error GoTo errorhandler
    
    Set frmA = New frmAuthOne
    With frmA
        .ubFunc = True
        .usCodePre = Left$(tvwAuth.SelectedItem.text, InStr(1, tvwAuth.SelectedItem, "=") - 1)
        .usCode = ""
        .usName = ""
        .usMenuName = tvwAuth.SelectedItem.Tag
        .Caption = "新增权限"
        .Show 1, Me
        If .OK Then
            Set adoCmd = New ADODB.Command
            adoCmd.ActiveConnection = gloSys.cnnSys
            adoCmd.CommandType = adCmdText
            adoCmd.CommandText = "INSERT INTO tSYS_Auth(AuthID,AuthName,AuthMenuName,bEnd) values('" & _
                    .usCodePre & .usCode & "','" & .usName & "','" & .usMenuName & "'," & _
                    IIf(.ubEnd, "-1", "0") & ")"
            adoCmd.Execute
            
            If .ubEnd Then
                Set Nodx = tvwAuth.Nodes.Add(tvwAuth.SelectedItem.Key, tvwChild, _
                        "k" & .usCodePre & .usCode, .usCodePre & .usCode & "=" & .usName, _
                        "UnSelected", "Selected")
            Else
                Set Nodx = tvwAuth.Nodes.Add(tvwAuth.SelectedItem.Key, tvwChild, _
                        "k" & .usCodePre & .usCode, .usCodePre & .usCode & "=" & .usName, _
                        "Collapse", "Expand")
            End If
            Nodx.Tag = .usMenuName
            Nodx.Sorted = True
            Nodx.Expanded = True
            
            tvwAuth.Refresh
            Call tvwAuth_NodeClick(tvwAuth.Nodes(tvwAuth.SelectedItem.index))
        End If
    End With
    Unload frmA
    
    Exit Sub
errorhandler:
    MsgBox "更新权限记录集发生错误。" & vbCr & vbCr & Err.Number & vbTab & _
                    Err.Description, vbInformation
    Err.Clear
    
End Sub

Private Sub mnuTvwDelete_Click()
    Dim sTemp As String
    Dim adoCmd As ADODB.Command
    
    If MsgBox("确实要删除该键吗？", vbQuestion + vbYesNo) = vbYes Then
        sTemp = tvwAuth.SelectedItem.text
        sTemp = Left$(sTemp, InStr(1, sTemp, "=") - 1)
        Set adoCmd = New ADODB.Command
        adoCmd.ActiveConnection = gloSys.cnnSys
        adoCmd.CommandType = adCmdText
        adoCmd.CommandText = "delete from tSYS_Auth where AuthID='" & sTemp & "'"
        adoCmd.Execute
        adoCmd.CommandText = "delete from tSYS_UserAuth where AuthID='" & sTemp & "'"
        adoCmd.Execute
        tvwAuth.Nodes.Remove tvwAuth.SelectedItem.index
        Call tvwAuth_NodeClick(tvwAuth.Nodes(tvwAuth.SelectedItem.index))
    End If
    
End Sub

Private Sub mnuTvwEdit_Click()
    Dim frmA As frmAuthOne
    Dim adoCmd As ADODB.Command
    Dim sTemp As String, iTemp As Integer
    Set frmA = New frmAuthOne
    With frmA
        .ubFunc = False
        sTemp = tvwAuth.SelectedItem.Parent.text
        sTemp = Left$(sTemp, InStr(1, sTemp, "=") - 1)
        .usCodePre = sTemp
        iTemp = Len(sTemp)
        sTemp = tvwAuth.SelectedItem.text
        .usName = Mid$(sTemp, InStr(1, sTemp, "=") + 1)
        sTemp = Mid$(sTemp, iTemp + 1)
        sTemp = Left$(sTemp, InStr(1, sTemp, "=") - 1)
        .usCode = sTemp
        .usMenuName = tvwAuth.SelectedItem.Tag
        .ubEnd = (tvwAuth.SelectedItem.Image = "UnSelected")
        .Caption = "修改权限"
        .Show 1, Me
        If .OK Then
            tvwAuth.SelectedItem.text = .usCodePre & .usCode & "=" & .usName
            tvwAuth.SelectedItem.Tag = .usMenuName
            If .ubEnd Then
                tvwAuth.SelectedItem.Image = "UnSelected"
                tvwAuth.SelectedItem.SelectedImage = "Selected"
            Else
                tvwAuth.SelectedItem.Image = "Collapse"
                tvwAuth.SelectedItem.SelectedImage = "Expand"
            End If
            
            Set adoCmd = New ADODB.Command
            adoCmd.ActiveConnection = gloSys.cnnSys
            adoCmd.CommandType = adCmdText
            adoCmd.CommandText = "Update tSYS_Auth set AuthName='" & .usName & _
                    "',AuthMenuName='" & .usMenuName & "',bEnd=" & IIf(.ubEnd, "-1", "0") & _
                    " where AuthID='" & .usCodePre & .usCode & "'"
            adoCmd.Execute
            
            tvwAuth.Refresh
            Call tvwAuth_NodeClick(tvwAuth.Nodes(tvwAuth.SelectedItem.index))
         End If
    End With
    Unload frmA

End Sub

Private Sub tBr_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
       Case "Append"
            Call mnuTvwAppend_Click
       Case "Delete"
            Call mnuTvwDelete_Click
       Case "Modify"
            Call mnuTvwEdit_Click
       Case "Exit"
             Unload Me
       Case "Help"
End Select
End Sub

'Private Sub tvwAuth_DblClick()
'    If mnuTvwEdit.Enabled Then
'        Call mnuTvwEdit_Click
'    End If
'End Sub

Private Sub tvwAuth_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then
        PopupMenu mnuTvw, , , , mnuTvwEdit
    End If
End Sub

Private Sub tvwAuth_NodeClick(ByVal Node As MSComctlLib.Node)
    Dim ItmX As ListItem
    Dim i As Long
    Dim Nodx As Node
    Dim iTemp As Integer
    
    If Node.Key = "R" Or Node.Image = "UnSelected" Then
        mnuTvwAppend.Enabled = False
        tBr.Buttons("Append").Enabled = False
    Else
        mnuTvwAppend.Enabled = True
        tBr.Buttons("Append").Enabled = True
    End If
    If Node.Key = "R" Then
        mnuTvwEdit.Enabled = False
        tBr.Buttons("Modify").Enabled = False
    ElseIf Node.Parent.Key = "R" Then
        mnuTvwEdit.Enabled = False
        tBr.Buttons("Modify").Enabled = False
    Else
        mnuTvwEdit.Enabled = True
        tBr.Buttons("Modify").Enabled = True
    End If
    If Node.Image = "UnSelected" Then
        mnuTvwDelete.Enabled = True
        tBr.Buttons("Delete").Enabled = True
    ElseIf Node.Image = "Collapse" And Node.children = 0 Then
        mnuTvwDelete.Enabled = True
        tBr.Buttons("Delete").Enabled = True
    Else
        mnuTvwDelete.Enabled = False
        tBr.Buttons("Delete").Enabled = False
    End If
    
    With lvwAuth.ListItems
        .Clear
        If Node.children > 0 Then
            Set Nodx = Node.Child
            i = 1
            Do Until i > Node.children
                iTemp = InStr(1, Nodx.text, "=")
                Set ItmX = .Add(, , Left$(Nodx.text, iTemp - 1))
                ItmX.SubItems(1) = Mid$(Nodx.text, iTemp + 1)
                ItmX.SubItems(2) = Nodx.Tag
                Set Nodx = Nodx.Next
                i = i + 1
            Loop
        End If
    End With
    
End Sub



Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If x > tvwAuth.Left + tvwAuth.Width And x < lvwAuth.Left And _
            y > tvwAuth.Top And y < tvwAuth.Top + tvwAuth.Height And _
            Button = 1 Then
        m_bMouseStart = True
    Else
        m_bMouseStart = False
    End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If x > tvwAuth.Left + tvwAuth.Width And x < lvwAuth.Left And _
            y > tvwAuth.Top And y < tvwAuth.Top + tvwAuth.Height Then
        Me.MousePointer = vbSizeWE
    Else
        Me.MousePointer = vbArrow
    End If
    If m_bMouseStart Then
        Me.MousePointer = vbSizeWE
    End If
End Sub

Private Sub tvwAuth_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If x > tvwAuth.Left + 500 And x < lvwAuth.Left + lvwAuth.Width - 500 _
                And y > tvwAuth.Top And y < tvwAuth.Top + tvwAuth.Height And _
                Button = 1 Then
        tvwAuth.Width = x - tvwAuth.Left
        lvwAuth.Width = lvwAuth.Width - (x + 30 - lvwAuth.Left)
        lvwAuth.Left = x + 30
    End If
    m_bMouseStart = False
End Sub

Private Sub lvwAuth_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Me.MousePointer = vbDefault
End Sub