frmuserset.frm

VB税控的源代码 主要用于地方税务局的税控引用 有完整的控件和代码

    If bCheckCharacter = False Then
        MsgBox "符号(')是本系统的特殊符号，请您选择别的符号代替它!", vbOKOnly + vbInformation, "提示信息"
        Exit Sub
    End If
    
    If Trim(cboUserID.Text) = "" Then
        MsgBox "用户ID不能为空,请确认", vbOKOnly + vbInformation, "提示信息"
        Exit Sub
    End If
    
    If gsEditUser = "E" And Trim(cboUserID.Text) <> gsUserID Then
        If Trim(cboUserID.Text) <> Trim(cboUserID.Tag) Then
            MsgBox "不能修改用户的ID，请确认！", _
                  vbOKOnly + vbInformation, "提示信息"
                  cboUserID.Text = cboUserID.Tag
            Exit Sub
        End If
    End If
    
    If gsEditUser <> "E" Then
        If bCheckUserID = False Then
            MsgBox "您所定义的用户ID已经存在，请确认！", _
                  vbOKOnly + vbInformation, "提示信息"
            Exit Sub
        End If
    End If
    
    If bCheckUserPower = False Then
        MsgBox "您还没有定义权限,请确认", vbOKOnly + vbInformation, "提示信息"
        Exit Sub
    End If
    
    
    If bCheckPWD = False Then Exit Sub
    
    If gsEditUser = "E" Then
        
        If bEditUserInfo(Trim(cboUserID.Text)) = False Then Exit Sub
        gsUserName = Trim(txtUserName.Text)
        MsgBox "用户修改完毕,请确认", vbOKOnly + vbInformation, "提示信息"
    Else
        If bAddUserInfo = False Then Exit Sub
        MsgBox "添加用户完毕,请确认", vbOKOnly + vbInformation, "提示信息"
    End If
    
    SaveFileInfo                                         '''保存日期
    Unload Me
End Sub

'检查用户权限
Private Function bCheckUserPower() As Boolean
    Dim i As Integer
    
    bCheckUserPower = True
    
    For i = 0 To 3
        If chkPower(i).Value = 1 Then Exit Function
    Next
    
    bCheckUserPower = False
End Function

Private Function bCheckCharacter() As Boolean
    
    bCheckCharacter = False
    
    If Len(txtUserName.Text) > 0 Then
        If InStr(txtUserName.Text, "'") > 0 Then
            txtUserName.SetFocus
            Exit Function
        End If
    End If
    If Len(txtPwd.Text) > 0 Then
        If InStr(txtPwd.Text, "'") > 0 Then
            txtPwd.SetFocus
            Exit Function
        End If
    End If
    If Len(txtNextPwd.Text) > 0 Then
        If InStr(txtNextPwd.Text, "'") > 0 Then
            txtNextPwd.SetFocus
            Exit Function
        End If
    End If
    
    If Len(cboUserID.Text) > 0 Then
        If InStr(cboUserID.Text, "'") > 0 Then
            cboUserID.SetFocus
            Exit Function
        End If
    End If
    
    bCheckCharacter = True
End Function

'检查用户的ID,是否已经改变
Private Function bCheckUserID() As Boolean
    Dim StrSQL As String
    Dim recUser As ADODB.Recordset
    
    bCheckUserID = False
    Set recUser = New ADODB.Recordset
    StrSQL = "select userid from " + gsconTabel + "is_user where userid='" + Trim(cboUserID.Text) + "'"
    If recUser.State = 1 Then recUser.Close
    recUser.CursorLocation = adUseClient
    recUser.Open StrSQL, gConn, adOpenStatic, adLockReadOnly
    
    If recUser.RecordCount <> 0 Then Exit Function
    bCheckUserID = True
End Function

Private Sub Form_Load()
'    cboPower.Text = "开发票 "
    
    If gsEditUser = "E" Then
        If bGetUserInfo(gsUserID) = False Then Exit Sub
        If gsUserID = "isa" Then
            AddUserID                    '''添加用户ID
            cmdDelete.Visible = True
            cmdDelete.Enabled = False
            
        Else
            cboUserID.AddItem gsUserID
            cboUserID.Enabled = False
            
        End If
        Frame2.Enabled = False
        cboUserID.Text = gsUserID
        cboUserID.Tag = gsUserID
    End If
End Sub

'添加用户ID
Private Sub AddUserID()
On Error GoTo err
    Dim StrSQL As String
    Dim recUser As ADODB.Recordset
 
    Set recUser = New ADODB.Recordset
    StrSQL = "select userid from " + gsconTabel + "is_user "
    If recUser.State = 1 Then recUser.Close
    recUser.CursorLocation = adUseClient
    recUser.Open StrSQL, gConn, adOpenStatic, adLockReadOnly
    
    If recUser.RecordCount < 1 Then Exit Sub
    
    Do Until recUser.EOF
        cboUserID.AddItem recUser.Fields(0)
        recUser.MoveNext
    Loop
    
    
    Exit Sub
err:

    MsgBox "不能获取用户信息!", vbOKOnly + vbInformation, "提示信息"
End Sub

'判断密码是否正确
Private Function bCheckPWD() As Boolean
    
    bCheckPWD = False
    If Trim(txtPwd.Text) = "" Then
        MsgBox "请输入密码!", vbOKOnly + vbInformation, "提示信息"
        Exit Function
    End If
    
    If Trim(txtPwd.Text) <> Trim(txtNextPwd.Text) Then
        MsgBox "密码不一致,请确认!", vbOKOnly + vbInformation, "提示信息"
        Exit Function
    End If
    
    bCheckPWD = True
End Function


'修改用户时，获取用户的信息
Private Function bGetUserInfo(vsUserid As String) As Boolean
On Error GoTo err
    Dim StrSQL As String
    Dim recUser As ADODB.Recordset
    
    bGetUserInfo = False
    Set recUser = New ADODB.Recordset
    StrSQL = "select * from " + gsconTabel + "is_user where userid ='" + vsUserid + "'"
    If recUser.State = 1 Then recUser.Close
    recUser.CursorLocation = adUseClient
    recUser.Open StrSQL, gConn, adOpenStatic, adLockReadOnly
    
    If recUser.RecordCount < 1 Then Exit Function
    
'    cboUserID.AddItem vsUserid
'    cboUserID.Text = vsUserid
'    cboUserID.Enabled = False
    
    txtUserName.Text = IIf(IsNull(recUser.Fields("username")), "", recUser.Fields("UserName"))
    txtPwd.Text = IIf(IsNull(recUser.Fields("userpd")), "", recUser.Fields("userpd"))
    txtNextPwd.Text = IIf(IsNull(recUser.Fields("userpd")), "", recUser.Fields("userpd"))
    
    If IsNull(recUser.Fields("userpower")) = False Then
        If recUser.Fields("userpower").Value = "abcd" Or vsUserid = "isa" Then
            chkPower(0).Value = 1
            DealPower 0
            
        ElseIf recUser.Fields("userpower").Value = "abc" Then
            chkPower(0).Value = 0
            chkPower(1).Value = 1
            DealPower 1
        ElseIf recUser.Fields("userpower").Value = "ab" Then
            chkPower(0).Value = 0
            chkPower(1).Value = 0
            chkPower(2).Value = 1
            DealPower 2
        Else
            chkPower(0).Value = 0
            chkPower(1).Value = 0
            chkPower(2).Value = 0
            chkPower(3).Value = 1
            DealPower 3
        End If
    End If
    
    bGetUserInfo = True
    Exit Function
err:

    MsgBox "不能获取用户信息!", vbOKOnly + vbInformation, "提示信息"
End Function


'修改用户信息
Private Function bEditUserInfo(vsUserid As String) As Boolean
On Error GoTo err
    Dim StrSQL As String
    Dim sPower As String
    
    sPower = sGetUserPower
    
    bEditUserInfo = False
    StrSQL = "update " + gsconTabel + "is_user set username='" + Trim(txtUserName.Text) + "'," + _
                              "userpd='" + Trim(txtPwd.Text) + " '," + _
                               "userpower='" + sPower + "'" + _
                               " where userid ='" + vsUserid + "'"
    gConn.Execute (StrSQL)
    
    bEditUserInfo = True
    Exit Function
err:

    MsgBox "修改用户信息失败,请确认!", vbOKOnly + vbInformation, "提示信息"
End Function

'增加用户信息
Private Function bAddUserInfo() As Boolean
    Dim StrSQL As String
    Dim sPower As String
    
    sPower = sGetUserPower
    StrSQL = "insert into " + gsconTabel + "is_user (username,userid,userpd,userpower) values " + _
                                  "( '" + Trim(txtUserName.Text) + "','" + _
                                     Trim(cboUserID.Text) + "','" + _
                                     Trim(txtPwd.Text) + "','" + _
                                     sPower + "')"
    gConn.Execute (StrSQL)
    bAddUserInfo = True
    Exit Function
err:
    MsgBox "增加用户失败,请确认!", vbOKOnly + vbInformation, "提示信息"
End Function

'获取用户权限
Private Function sGetUserPower() As String
    Dim sPower As String
    
    If chkPower(0).Value = 1 Then
        sPower = "abcd"
    ElseIf chkPower(1).Value = 1 Then
        sPower = "abc"
    ElseIf chkPower(2).Value = 1 Then
        sPower = "ab"
    Else
        sPower = "a"
    End If
    
    sGetUserPower = sPower
End Function