frmuser.frm

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

            
             SaveAllAuth .usCode
            
        End If
    End With
    Unload frmO
    
End Sub
Private Sub SaveAllAuth(sUserID As String)   '2002.07.08 add 默认无权限
            Dim rstTmp As New ADODB.Recordset
            Dim adoCmd As New ADODB.Command
            Dim rstAuth As New ADODB.Recordset
            
            Dim m_sAccountID As String
            Dim m_sAuthId As String

            
            rstTmp.CursorLocation = adUseClient
            rstAuth.CursorLocation = adUseClient
            
            adoCmd.ActiveConnection = gloSys.cnnSys
            
            rstTmp.Open "select AccountID,AccountName from tSYS_Account", gloSys.cnnSys, adOpenStatic, adLockReadOnly
            rstAuth.Open "select AuthID from tsys_auth", gloSys.cnnSys, adOpenStatic, adLockReadOnly
            '注tsys_userauth插入的是没有的权限
            While Not rstTmp.EOF
                        '循环账套号
                        m_sAccountID = rstTmp.Fields("AccountID").Value
                        If rstAuth.RecordCount > 0 Then rstAuth.MoveFirst
                While Not rstAuth.EOF
                        m_sAuthId = rstAuth.Fields("AuthID").Value
                        adoCmd.CommandText = "INSERT INTO tSYS_UserAuth(AccountID,UserID,AuthID) values('" & _
                        m_sAccountID & "','" & sUserID & "','" & m_sAuthId & "')"
                        adoCmd.Execute
                        rstAuth.MoveNext
                Wend
                        rstTmp.MoveNext
            Wend

End Sub
Private Sub mnuPopDelete_Click()
    Dim adoCmd As ADODB.Command
        
    If MsgBox("提示：如果该人员做过凭证等操作，建议不要删除，否则会影响相关信息的查看！确实要删除该人员吗？", vbQuestion + vbYesNo) = vbYes Then
    
'        If CheckUsed(Mid$(tvwUser.SelectedItem.Key, 2)) = True Then
'            Exit Sub
'        End If
    
        Set adoCmd = New ADODB.Command
        adoCmd.ActiveConnection = gloSys.cnnSys
        adoCmd.CommandType = adCmdText
        adoCmd.CommandText = "delete from tSYS_user where userID='" & _
                Mid$(tvwUser.SelectedItem.Key, 2) & "'"
        adoCmd.Execute
        
        adoCmd.CommandText = "delete from tSYS_UserAuth where userid='" & Mid$(tvwUser.SelectedItem.Key, 2) & "'"
        adoCmd.Execute
        
        
        tvwUser.Nodes.Remove tvwUser.SelectedItem.index
    End If
End Sub
Private Function CheckUsed(sPersonCode As String) As Boolean   '2002.07.12 add
    Dim rstAccount As New ADODB.Recordset
    Dim rstUsed As New ADODB.Recordset
    
    Dim m_sAccountID As String
    Dim sSql As String
    
    rstAccount.CursorLocation = adUseClient
    rstUsed.CursorLocation = adUseClient
    
    CheckUsed = False
    rstAccount.Open "select AccountID from tSYS_Account", gloSys.cnnSys, adOpenStatic, adLockReadOnly

    Do While rstAccount.EOF = False
        m_sAccountID = Trim(rstAccount.Fields("AccountID").Value & "")
        sSql = "SELECT * FROM tSYS_SubSysUsed WHERE AccountID='" & m_sAccountID & _
            "' AND SubSysID='ZW'"

         rstUsed.Open sSql, gloSys.cnnSys, adOpenStatic, adLockReadOnly

         If rstUsed.RecordCount <> 0 Then

          sSql = Trim(rstUsed.Fields("ModiYear").Value & "")
          If sSql < Trim(rstUsed.Fields("beginyear").Value & "") Then
             sSql = sSql + 1
          End If

            If CheckHave(m_sAccountID, sSql, sPersonCode) = True Then
                CheckUsed = True
                Exit Do
            End If
        End If
        rstUsed.Close
        rstAccount.MoveNext
    Loop
    
    
End Function
Private Function CheckHave(sAccountID As String, sYear As String, cPersonCode As String) As Boolean
    On Error GoTo err1
    Dim Cnn As New ADODB.Connection
    
    Dim rstPZ As New ADODB.Recordset
    rstPZ.CursorLocation = adUseClient
    
    CheckHave = False
    Cnn.Open GetConnectString(g_FLAT, gloSys.sServer, "cwdb" & sAccountID, "ykcwdb" & sAccountID, "cwdb" & sAccountID)
    rstPZ.Open "select count(*) from " & _
                 " tzw_pzsj" & sYear & " where zdrmCode='" & cPersonCode & _
                 "' or fhrmCode='" & cPersonCode & "' or zgrmCode='" & cPersonCode & _
                 "'", Cnn, adOpenStatic, adLockReadOnly
                 
    If val(rstPZ.Fields(0).Value & "") > 0 Then
        MsgBox "当前人员编码" & cPersonCode & "被账套号" & sAccountID & "使用,不能修改或删除！", vbInformation, "提示"
        CheckHave = True
    End If
    
err1:
    
End Function
Private Sub mnuPopEdit_Click()
    Dim frmO As frmUserOne
    Dim sTemp As String
    Dim adoCmd As ADODB.Command
    
        If CheckUsed(Mid$(tvwUser.SelectedItem.Key, 2)) = True Then
            Exit Sub
        End If
    
    Set frmO = New frmUserOne
    With frmO
        .ubFunc = False
        .usCode = Mid$(tvwUser.SelectedItem.Key, 2)
        sTemp = tvwUser.SelectedItem.text
        .usName = Mid$(sTemp, InStr(1, sTemp, "=") + 1)
        .Caption = "修改操作员名称"
        .Show 1, Me
        If .OK Then
            tvwUser.SelectedItem.text = .usCode & "=" & .usName
            Set adoCmd = New ADODB.Command
            adoCmd.ActiveConnection = gloSys.cnnSys
            adoCmd.CommandType = adCmdText
            adoCmd.CommandText = "Update tSYS_user set userName='" & _
                .usName & "' where userID='" & .usCode & "'"
            adoCmd.Execute
        End If
    End With
    Unload frmO
    
End Sub
Private Sub tBr_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
       Case "Append"
            Call mnuPopAppend_Click
       Case "Delete"
            Call mnuPopDelete_Click
       Case "Modify"
            Call mnuPopEdit_Click
       Case "Exit"
             Unload Me
       Case "Help"
'            Call mnuHelpTheme_Click
'             SendKeys "{F1}"
End Select
End Sub
Private Sub tvwUser_DblClick()
    If mnuPopEdit.Enabled Then
        Call mnuPopEdit_Click
    End If
End Sub
Private Sub tvwUser_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then
        PopupMenu mnuPop, , , , mnuPopEdit
    End If
End Sub
Private Sub tvwUser_NodeClick(ByVal Node As MSComctlLib.Node)
    If Node.Key = "Normal" Then
        mnuPopAppend.Enabled = True
        tBr.Buttons("Append").Enabled = True
    Else
        mnuPopAppend.Enabled = False
        tBr.Buttons("Append").Enabled = False
    End If
    If Node.Key Like "k*" Then
        If Node.Parent.Key = "Normal" Then
            mnuPopEdit.Enabled = True
            tBr.Buttons("Modify").Enabled = True
            mnuPopDelete.Enabled = True
            tBr.Buttons("Delete").Enabled = True
        ElseIf Node.Parent.Key = "Master" Then
            mnuPopEdit.Enabled = False
            tBr.Buttons("Modify").Enabled = False
            mnuPopDelete.Enabled = False
            tBr.Buttons("Delete").Enabled = False
        Else
            mnuPopEdit.Enabled = False
            tBr.Buttons("Modify").Enabled = False
            mnuPopDelete.Enabled = False
            tBr.Buttons("Delete").Enabled = False
        End If
    Else
        mnuPopEdit.Enabled = False
       tBr.Buttons("Modify").Enabled = False
        mnuPopDelete.Enabled = False
        tBr.Buttons("Delete").Enabled = False

    End If
End Sub
''Private Sub mnuHelpTheme_Click()
''    Dim nRet As Integer
''
''    'if there is no helpfile for this project display a message to the user
''    'you can set the HelpFile for your application in the
''    'Project Properties dialog
''    If Len(App.HelpFile) = 0 Then
''        MsgBox "Unable to display Help Contents. There is no Help associated with this project.", vbInformation
''    Else
''        On Error Resume Next
''        nRet = OSWinHelp(Me.hwnd, App.HelpFile, 3, 0)
''        If Err Then
''            MsgBox Err.Description
''        End If
''    End If
''
''End Sub
'''判断该人员是否设置了权限
''Private Function isExistAuth(sCode As String) As Boolean
''   Dim rst As New ADODB.Recordset
''   rst.Open "", gloSys.cnnSys, adOpenStatic, adLockReadOnly
''   If rst.RecordCount > 0 Then
''      isExistAuth = True
''   Else
''      isExistAuth = False
''   End If
''End Function