frmmutex.frm

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

                lvw1.ListItems.Remove j
                Exit For
            End If
        Next j
    End If
Next i
End Sub

Private Sub cmdExit_Click()
Unload Me
End Sub

Private Sub cmdSave_Click()
Dim adoCmd As New ADODB.Command
Dim i As Integer
On Error GoTo HandleErr
With adoCmd
    .ActiveConnection = gloSys.cnnSys
    .CommandType = adCmdText
    .CommandText = "delete from tsys_MutexInfo where subsysid='" & _
        m_sSub(cboSub1.ListIndex + 1) & "' and AuthMenuName='" & _
        m_sAuthMenuName1(lvwMenu.SelectedItem.index) & "'"
    .Execute
    For i = 1 To lVw.ListItems.Count
        .CommandText = "insert into tsys_MutexInfo(subsysId," & _
            "AuthMenuName,MutexSubsysID,MutexAuthMenuName) values('" & _
            m_sSub(cboSub1.ListIndex + 1) & "','" & m_sAuthMenuName1(lvwMenu.SelectedItem.index) & _
            "','" & lVw.ListItems(i).Tag & "','" & Mid(lVw.ListItems(i).Key, 3) & "')"
        .Execute
    Next i
    MsgBox "保存成功！", vbInformation, "提示"
End With
Exit Sub
HandleErr:
    MsgBox Err.Number & vbTab & Err.Description, vbInformation, "提示"
End Sub

Private Sub cmdSelect_Click()
Dim i As Integer
Dim ItmX As ListItem
For i = lvw1.ListItems.Count To 1 Step -1
    If lvw1.ListItems(i).Selected Then
        Set ItmX = lVw.ListItems.Add(, lvw1.ListItems(i).Key, cboSub2.text)
        ItmX.SubItems(1) = lvw1.ListItems(i).SubItems(1)
        ItmX.Tag = m_sSub(cboSub2.ListIndex + 1)
        lvw1.ListItems.Remove i
    End If
Next i
End Sub

Private Sub cmdUnSelect_Click()
Dim i As Integer
Dim ItmX As ListItem
For i = lVw.ListItems.Count To 1 Step -1
    If lVw.ListItems(i).Selected Then
        If lVw.ListItems(i).Tag = m_sSub(cboSub2.ListIndex + 1) Then
            Set ItmX = lvw1.ListItems.Add(, lVw.ListItems(i).Key, cboSub2.text)
            ItmX.SubItems(1) = lVw.SelectedItem.SubItems(1)
            ItmX.Tag = m_sSub(cboSub2.ListIndex + 1)
        End If
        lVw.ListItems.Remove i
    End If
Next i
End Sub

Private Sub Form_Load()
Dim rSt As New ADODB.Recordset
Dim i As Integer
With lvwMenu
    .ColumnHeaders.Add , , "功能菜单", 3000, 0
    .HideColumnHeaders = True
End With
With lVw.ColumnHeaders
    .Add , , "子系统", 1350, 0
    .Add , , "功能菜单", 2200, 0
End With
With lvw1.ColumnHeaders
    .Add , , "子系统", 1350, 0
    .Add , , "功能菜单", 2200, 0
End With
lvw1.Sorted = True
lvw1.SortKey = 0
ReDim m_sSub(1)
With rSt
    .CursorLocation = adUseClient
    .Open "Select * from tsys_SubSys order by SubSysID", _
        gloSys.cnnSys, adOpenStatic, adLockReadOnly
    If .RecordCount > 0 Then
        ReDim m_sSub(.RecordCount)
        i = 1
        Do Until .EOF
            cboSub1.AddItem Trim(.Fields("SubSysName").Value)
            cboSub2.AddItem Trim(.Fields("SubSysName").Value)
            m_sSub(i) = Trim(.Fields("SubSysID").Value)
            i = i + 1
            .MoveNext
        Loop
    End If
    .Close
    If cboSub1.ListCount > 0 Then
        cboSub1.ListIndex = 0
        cboSub2.ListIndex = 0
    End If
End With
Call lvwMenu_Click
lvw1.Refresh
lVw.Refresh
End Sub
Private Sub LoadAuth(ByVal cboTemp As ComboBox)
Dim rSt As New ADODB.Recordset
Dim sSql As String, i As Integer
Dim ItmX As ListItem
    If UCase(cboTemp.Name) = "CBOSUB1" Then
        ReDim m_sAuthMenuName1(1)
    End If
    With rSt
        .CursorLocation = adUseClient
        If g_FLAT = "SQL" Then
            sSql = "select * from tsys_auth where bEnd<> '0' and substring(AuthID,1,2)='" & _
                m_sSub(cboTemp.ListIndex + 1) & "' order by AuthID"
        ElseIf g_FLAT = "ORACLE" Then
            sSql = "select * from tsys_auth where bEnd<> '0' and substr(AuthID,1,2)='" & _
                m_sSub(cboTemp.ListIndex + 1) & "' order by AuthID"
        End If
        .Open sSql, gloSys.cnnSys, adOpenStatic, adLockReadOnly
        If .RecordCount > 0 Then
            If UCase(cboTemp.Name) = "CBOSUB1" Then
                ReDim m_sAuthMenuName1(.RecordCount)
            End If
            i = 1
            Do Until .EOF
              On Error GoTo errorhandle:
                If UCase(cboTemp.Name) = "CBOSUB1" Then
                    lvwMenu.ListItems.Add , , Trim("" & .Fields("AuthName").Value)
                    m_sAuthMenuName1(i) = Trim("" & .Fields("AuthMenuName").Value)
                ElseIf UCase(cboTemp.Name) = "CBOSUB2" Then
              On Error GoTo errorhandle:
                    Set ItmX = lvw1.ListItems.Add(, m_sSub(cboSub2.ListIndex + 1) & Trim("" & .Fields("AuthMenuName").Value), cboSub2.text)
                    ItmX.SubItems(1) = Trim("" & .Fields("AuthName").Value)
                    ItmX.Tag = m_sSub(cboSub2.ListIndex + 1)
                End If
errorhandle:
                i = i + 1
                .MoveNext
            Loop
        End If
        .Close
    End With
End Sub

Private Sub Form_Resize()
On Error GoTo HandleErr
HandleErr:
End Sub

Private Sub lvwMenu_Click()
Dim rSt As New ADODB.Recordset
Dim i As Integer
Dim sSql As String
Dim ItmX As ListItem
lVw.ListItems.Clear

If lvwMenu.ListItems.Count > 0 Then
   bFlag = True
    txtName.text = lvwMenu.SelectedItem.text
    lvw1.ListItems.Clear
    Call LoadAuth(cboSub2)
    cboSub2.ListIndex = 0
    With rSt
        .CursorLocation = adUseClient
        If g_FLAT = "SQL" Then
            sSql = "select Distinct a.MutexSubSysID,a.MutexAuthMenuName,b.SubSysName,c.AuthName " & _
                " from tsys_MutexInfo a,tsys_SubSys b,tsys_Auth c " & _
                " where a.MutexSubSysID=substring(c.AuthID,1,2) and b.SubSysID=Substring(c.AuthID,1,2) and " & _
                " a.MutexAuthMenuName=c.AuthMenuName and  a.SubSysID='" & _
                m_sSub(cboSub1.ListIndex + 1) & "' and a.AuthMenuName='" & _
                m_sAuthMenuName1(lvwMenu.SelectedItem.index) & _
                "' and a.MutexSubSysID=b.SubSysID order by a.MutexSubSysID,a.MutexAuthMenuName"
        ElseIf g_FLAT = "ORACLE" Then
            sSql = "select Distinct a.MutexSubSysID,a.MutexAuthMenuName,b.SubSysName,c.AuthName " & _
                " from tsys_MutexInfo a,tsys_SubSys b,tsys_Auth c " & _
                " where a.MutexSubSysID=substr(c.AuthID,1,2) and  b.SubSysID=Substr(c.AuthID,1,2) and " & _
                " a.MutexAuthMenuName=c.AuthMenuName and  a.SubSysID='" & _
                m_sSub(cboSub1.ListIndex + 1) & "' and a.AuthMenuName='" & _
                m_sAuthMenuName1(lvwMenu.SelectedItem.index) & _
                "' and a.MutexSubSysID=b.SubSysID order by a.MutexSubSysID,a.MutexAuthMenuName"
        End If
        .Open sSql, gloSys.cnnSys, adOpenStatic, adLockReadOnly
        If .RecordCount > 0 Then
            Do Until .EOF
                If Trim(.Fields(0).Value) = m_sSub(cboSub2.ListIndex + 1) Then
                    For i = lvw1.ListItems.Count To 1 Step -1
                        If Trim(.Fields(1).Value) = Mid(lvw1.ListItems(i).Key, 3) Then
                           lvw1.ListItems.Remove i
                            Exit For
                        End If
                    Next i
                End If
                Set ItmX = lVw.ListItems.Add(, Trim(.Fields(0).Value) & Trim(.Fields(1).Value), Trim(.Fields(2).Value))
                ItmX.SubItems(1) = Trim(.Fields(3).Value)
                ItmX.Tag = Trim(.Fields(0).Value)
                .MoveNext
            Loop
        End If
        .Close
    End With
End If
bFlag = False
End Sub


Private Sub lvw_DblClick()
Dim ItmX As ListItem
If lVw.ListItems.Count > 0 Then
    If lVw.SelectedItem.index <> -1 Then
        If lVw.SelectedItem.Tag = m_sSub(cboSub2.ListIndex + 1) Then
            Set ItmX = lvw1.ListItems.Add(, lVw.SelectedItem.Key, cboSub2.text)
            ItmX.SubItems(1) = lVw.SelectedItem.SubItems(1)
            ItmX.Tag = m_sSub(cboSub2.ListIndex + 1)
        End If
        lVw.ListItems.Remove lVw.SelectedItem.index
    End If
End If
End Sub


Private Sub lvw1_DblClick()
Dim ItmX As ListItem
If lvw1.ListItems.Count > 0 Then
    If lvw1.SelectedItem.index <> -1 Then
        Set ItmX = lVw.ListItems.Add(, lvw1.SelectedItem.Key, cboSub2.text)
        ItmX.SubItems(1) = lvw1.SelectedItem.SubItems(1)
        ItmX.Tag = m_sSub(cboSub2.ListIndex + 1)
        lvw1.ListItems.Remove lvw1.SelectedItem.index
    End If
End If
End Sub


Private Sub txtName_Change()
Dim ItmX As ListItem
If Not bFlag Then
    If lvwMenu.ListItems.Count > 0 Then
        Set ItmX = lvwMenu.FindItem(Trim(txtName.text), , , lvwPartial)
        If ItmX Is Nothing Then
        Else
            ItmX.EnsureVisible
            ItmX.Selected = True
        End If
    End If
End If
End Sub