frmuser.frm

朋友给的

         ForeColor       =   &H00000000&
         Height          =   270
         Left            =   240
         TabIndex        =   9
         Top             =   315
         Width           =   810
      End
   End
End
Attribute VB_Name = "frmUser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim rs        As New ADODB.Recordset

Private Sub cmdHelp_Click()
    App.HelpFile = App.Path & "\帮助系统.chm"
    SendKeys "{F1}"
    cmdHelp.HelpContextID = 1013
End Sub

Private Sub cmdQXGL_Click()
        
        
    'If txtUserID.Text = "1001" Then: MsgBox "此为超级用户，必须保留所有权限！", vbInformation, "系统提示": Exit Sub
    If txtUserID.Text = "" Then: MsgBox "请选择需要配置权限的用户！", vbInformation, "系统提示": Exit Sub
    frmQXGL.txtUserID.Text = txtUserID.Text
    frmQXGL.txtUserName.Text = txtUserName.Text
    frmQXGL.Show
    
End Sub

Private Sub Form_Activate()
    frmMain.StatusBar1.Panels(2).Text = "用户新增、修改、删除及权限设置......"
    Me.Move 0, 0
End Sub

Private Sub Form_Load()
On Error Resume Next
    Dim i As Long
    Me.Move 0, 0
    'If Me.WindowState = 0 Then Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2 - 600
    If rs.State = 1 Then rs.Close
    gSQL = "select EmployeeID as 用户代码,[Name] as 用户名,[PassWord] as 密码,ID as 标识 from [sysuser] order by EmployeeID"
    rs.Open gSQL, gCnn, adOpenForwardOnly, adLockBatchOptimistic
    Call ShowList(rs, gSQL, Lvwyh)
    If Lvwyh.ListItems.count > 0 Then Call Lvwyh_ItemClick(Lvwyh.ListItems.Item(1))
    If rs.State = 1 Then rs.Close
   rs.Open "select 工号,姓名 from viewygxx order by  工号", gCnn, adOpenStatic, adLockReadOnly
   txtUserName.Clear
   txtUserName = "0000-其他"
   For i = 0 To rs.RecordCount - 1
        txtUserName.AddItem rs("工号") & "-" & rs("姓名")
        rs.MoveNext
   Next

End Sub


Private Sub chkSysUser_Click(Index As Integer)

On Error Resume Next
    If chkSysUser(Index).Value > 0 Then
        Select Case Index
        Case 0
            chkSysUser(1) = 0
            chkSysUser(2) = 0
        Case 1
            chkSysUser(0) = 0
            chkSysUser(2) = 0
        Case 2
            chkSysUser(0) = 0
            chkSysUser(1) = 0
        End Select
    End If
End Sub

Private Sub cmdSave_Click()
Dim strsql     As String
Dim rsUser     As ADODB.Recordset
Dim i          As Integer

On Error GoTo ErrorK
    
    If txtUserID = "" Then
       frmMain.StatusBar1.Panels(2).Text = "用户代码不可为空！"
       txtUserID.SetFocus
       Exit Sub
    ElseIf Trim(txtOldPass) <> Trim(txtNewPass) Then
       frmMain.StatusBar1.Panels(2).Text = "两次密码不一致、请确认密码是否正确！"
       Exit Sub
    End If
    
    For i = 0 To 2
        If chkSysUser(i).Value > 0 Then Exit For
    Next
        
    If i = 3 Then frmMain.StatusBar1.Panels(2).Text = "帐号权限没有分配！": Exit Sub
    If cmdDelete.Enabled = True And cmdAddNew.Enabled = True Then txtUserID.Locked = True
    
    Set rsUser = New ADODB.Recordset
    rsUser.Open "sysuser", gCnn, adOpenStatic, adLockOptimistic
    rsUser.Filter = "EMPLOYEEID='" & Trim(txtUserID) & "'"
    If rsUser.EOF Then
        rsUser.AddNew
        rsUser.Fields("EMPLOYEEID") = txtUserID & ""
        rsUser.Fields("NAME") = txtUserName.Text & ""
        rsUser.Fields("PASSWORD") = txtNewPass.Text & ""
        rsUser.Fields("state") = "正常使用"
'        rsUser.Fields("用户权限") = i
        rsUser.Fields("workingdate") = Date
        rsUser.Update
    Else
        If Trim(txtUserID) = "1001" Then
            frmMain.StatusBar1.Panels(2).Text = "系统默认帐号，只能修改密码。"
            rsUser.Fields("NAME") = "godwin"
'            rsUser.Fields("用户权限") = 0
            rsUser.Fields("PASSWORD") = txtNewPass.Text
            rsUser.Update
            rsUser.Filter = ""
            chkSysUser(0).Value = 1
        Else
            rsUser.Fields("EMPLOYEEID") = txtUserID & ""
            rsUser.Fields("NAME") = txtUserName.Text & ""
            rsUser.Fields("PASSWORD") = txtNewPass.Text & ""
            rsUser.Fields("state") = "正常使用"
'            rsUser.Fields("用户权限") = i
            rsUser.Fields("workingdate") = Date
            rsUser.Update
        End If
        If txtUserID.Locked = False Then
          frmMain.StatusBar1.Panels(2).Text = "此用户代码已存在，请另选用户代码！"
          txtUserID.SetFocus
          SendKeys "{HOME} +{END}"
        End If
    End If

    Set rsUser = Nothing
    Call Form_Load
    frmMain.StatusBar1.Panels(2).Text = "用户帐号设置保存成功！"
    cmdDelete.Enabled = True
    cmdAddNew.Enabled = True
    Exit Sub
ErrorK:
    MsgBox "系统出错，可能操作不正确，请仔细核对后再试，或者与管理员联系！" & vbCr & Err.Description, vbCritical, "系统提示"
    Set rsUser = Nothing
End Sub

Private Sub cmdAddnew_Click()

On Error Resume Next
    '初始数据
    txtUserID = ""
    txtUserName = ""
    txtNewPass = ""
    txtOldPass = ""

    chkSysUser(0).Value = 1
    fraCHK.Enabled = True
    cmdAddNew.Enabled = False
    cmdDelete.Enabled = False
    txtUserID.Locked = False
    txtUserID.SetFocus
End Sub

Private Sub cmdDelete_Click()
    If Trim(txtUserID.Text) = "1001" Then
       frmMain.StatusBar1.Panels(2).Text = "此用户代码不可删除、是系统默认帐号！"
       Exit Sub
    End If
    gCnn.Execute "Delete  from sysuser where EMPLOYEEID='" & Trim(txtUserID) & "'"
    frmMain.StatusBar1.Panels(2).Text = "该帐号已经删除！"
    Call Form_Load
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub ShowList(rsList As ADODB.Recordset, strsql As String, lstName As Object)
Dim i As Integer
Dim k As Integer

On Error GoTo EndLabel

    Set rsList = New ADODB.Recordset
    If rsList.State = 1 Then rsList.Close
    rsList.Open strsql, gCnn, adOpenForwardOnly, adLockReadOnly
    If rsList.State = 0 Then Exit Sub
    lstName.Sorted = False
    lstName.ListItems.Clear
    lstName.ColumnHeaders.Clear
    For k = 1 To rsList.Fields.count
            lstName.ColumnHeaders.Add k, , rsList.Fields(k - 1).name
    Next
    If Not rsList.BOF Then rsList.MoveFirst
    i = 1
    Do While Not rsList.EOF                 'i <= rsList.RecordCount
        lstName.ListItems.Add , i & "_M", rsList.Fields(0).Value, 1
        For k = 1 To rsList.Fields.count - 1
            Select Case rsList.Fields(k).name
            Case "用户密码", "密码"
                lstName.ListItems(i).SubItems(k) = String(Len(Trim(rsList.Fields(k).Value & "")), "*")
            Case "用户权限", "权限组"
                If rsList.Fields(k).Value = 0 Then
                    lstName.ListItems(i).SubItems(k) = "系统管理员"
                ElseIf rsList.Fields(k).Value = 1 Then
                    lstName.ListItems(i).SubItems(k) = "一般操作员"
                Else
                    lstName.ListItems(i).SubItems(k) = "窗口操作员"
                End If
            Case Else
                lstName.ListItems(i).SubItems(k) = Trim(rsList.Fields(k).Value & "")
            End Select
        Next
        rsList.MoveNext
        i = i + 1
    Loop
    
    Set rsList = Nothing
    Exit Sub
EndLabel:
    MsgBox "系统出错，可能操作不正确，" _
         & "请仔细核对后再试，或者与管理员联系！" _
         & vbCr & Err.Description, vbCritical, "系统提示"
    Set rsList = Nothing
End Sub

Private Sub Lvwyh_ItemClick(ByVal Item As MSComctlLib.ListItem)
        
On Error Resume Next
    txtUserID = Lvwyh.ListItems(Item.Index).Text
    txtUserName = Lvwyh.ListItems(Item.Index).ListSubItems(1).Text
    txtNewPass = Lvwyh.ListItems(Item.Index).ListSubItems(2).Text
    txtOldPass = Lvwyh.ListItems(Item.Index).ListSubItems(2).Text
    Select Case Trim(Lvwyh.ListItems(Item.Index).ListSubItems(3).Text)
    Case "一般操作员", "操作员": chkSysUser(1).Value = 1
    Case "系统管理员", "管理员": chkSysUser(0).Value = 1
    Case Else: chkSysUser(2).Value = 1
    End Select

    If Trim(txtUserID.Text) = "1001" Then
        fraCHK.Enabled = False
        cmdDelete.Enabled = False
    Else
        fraCHK.Enabled = True
        cmdDelete.Enabled = True
    End If
End Sub
Private Sub Lvwyh_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
    If Lvwyh.Sorted And ColumnHeader.Index - 1 = Lvwyh.SortKey Then
        Lvwyh.SortOrder = lvwDescending
    Else
        Lvwyh.SortOrder = lvwAscending
        Lvwyh.SortKey = ColumnHeader.Index - 1
    End If
    Lvwyh.Sorted = True
End Sub

Private Sub txtUserName_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then
    Dim srtYGGH As String
    '===========查找员工编号
    Dim hh As Long
    For hh = 1 To Len(txtUserName.Text)
        srtYGGH = Left(txtUserName, hh)
        If Right(srtYGGH, 1) = "-" Then
            srtYGGH = Left(srtYGGH, Len(srtYGGH) - 1)
            Exit For
        End If
    Next
    '===========查找员工编号
    
       txtUserName.Text = CheckGhLy(srtYGGH, txtUserName)

    SendKeys "{Tab}"
    End If

End Sub
Private Function CheckGhLy(strTemp As String, ComboxTemp As ComboBox) As String
    Dim i, j As Integer
    Dim sTemp As String
    
    If strTemp = "" Then
       CheckGhLy = "0000-其他"
       Exit Function
    End If
    
    strTemp = Trim(strTemp)
    If ComboxTemp.ListCount <= 0 Then Exit Function
    CheckGhLy = ""
    For i = 0 To ComboxTemp.ListCount
'        If Left(ComboxTemp.List(i), 4) = strTemp Then
        For j = 1 To Len(ComboxTemp.List(i)) - 1
            sTemp = Mid(ComboxTemp.List(i), j, 1)
            If sTemp = "-" Then
                If Left(ComboxTemp.List(i), j - 1) = strTemp Then
                    CheckGhLy = Mid(ComboxTemp.List(i), j + 1, 10)
                    CheckGhLy = ComboxTemp.List(i)
                    Exit Function
                End If
            End If
        Next j
    Next i
    If CheckGhLy = "" Then
       MsgBox "没有此员工,请核对!", vbInformation, "系统提示"
       CheckGhLy = "0000-其他"
    End If
End Function