frmuser.frm

超市销售管理系统 4) 文档里面有完整的需求说明书

         Value           =   0   'False
         cBack           =   -2147483633
      End
      Begin SuperMarket.XPButton cmdOK 
         Default         =   -1  'True
         Height          =   345
         Left            =   1740
         TabIndex        =   8
         Top             =   2310
         Width           =   1095
         _ExtentX        =   1931
         _ExtentY        =   609
         Caption         =   "添加"
         CapAlign        =   2
         BackStyle       =   2
         BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "新宋体"
            Size            =   9
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Mode            =   0
         Value           =   0   'False
         cBack           =   -2147483633
      End
      Begin VB.Label lbPW 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "密码不改留空"
         ForeColor       =   &H00800000&
         Height          =   180
         Left            =   360
         TabIndex        =   17
         Top             =   2400
         Width           =   1080
      End
      Begin VB.Label Label5 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "密  码："
         Height          =   180
         Left            =   360
         TabIndex        =   16
         Top             =   915
         Width           =   720
      End
      Begin VB.Label Label2 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "用户名："
         Height          =   180
         Left            =   360
         TabIndex        =   15
         Top             =   435
         Width           =   720
      End
      Begin VB.Label Label3 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "确  认："
         Height          =   180
         Left            =   360
         TabIndex        =   14
         Top             =   1395
         Width           =   720
      End
      Begin VB.Label Label4 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "类  型："
         Height          =   180
         Left            =   360
         TabIndex        =   13
         Top             =   1875
         Width           =   720
      End
   End
End
Attribute VB_Name = "frmUser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'超市销售系统
'程序开发：lc_mtt
'CSDN博客：http://blog.csdn.net/lc_mtt/
'个人主页：http://www.3lsoft.com
'邮箱：[e-mail]
'注：此代码禁止用于商业用途。有修改者发我一份，谢谢！
'---------------- 开源世界，你我更进步 ----------------

Private Sub cmdAdd_Click()
    cmdOK.caption = "添加"
    freItem.caption = " 添加用户 "
    txtUser.Text = ""
    txtPW.Text = ""
    txtPW2.Text = ""
    lbPW.Visible = False
    LoadcboStyle
    cboStyle.ListIndex = 0
    ShowItemFrame True
    txtUser.SetFocus
End Sub

Private Sub cmdDel_Click()
On Error GoTo aaaa
    Dim Item As ListItem
    Set Item = List1.SelectedItem
    Dim j As Long
    j = CLng(Left$(Item.SubItems(2), 1))
    If j >= curUserStyle And curUserStyle <> 4 Then
        MsgBox "您没有权限删除该用户！", vbExclamation
        List1.SetFocus
        Exit Sub
    End If
    If StrComp(curUserName, Item.SubItems(1), 1) = 0 Then
        MsgBox "不能删除自己。", vbInformation
        Exit Sub
    End If
    If MsgBox("确定删除这个用户吗： [" & MID$(Item.SubItems(2), 3) & "] " & Item.SubItems(1), vbInformation + vbOKCancel) = vbCancel Then Exit Sub
    cnMain.Execute "Delete From [User] Where UserName='" & Item.SubItems(1) & "'"
    SetSB 2, "删除用户 " & Item.SubItems(1) & " 成功."
    List1.ListItems.Remove Item.Index
    List1.SetFocus
Exit Sub
aaaa:
    MsgBox Err.Description, vbCritical
End Sub

Private Sub cmdEdit_Click()
On Error GoTo aaaa
    Dim Item As ListItem
    Set Item = List1.SelectedItem
    Dim j As Long
    j = CLng(Left$(Item.SubItems(2), 1))
    If j >= curUserStyle And curUserStyle <> 4 Then
        MsgBox "您没有权限编辑该用户！", vbExclamation
        List1.SetFocus
        Exit Sub
    End If
    If StrComp(curUserName, Item.SubItems(1), 1) = 0 Then cboStyle.Enabled = False
    
    txtUser.Text = Item.SubItems(1)
    txtUser.Tag = Item.SubItems(1)
    txtPW.Text = ""
    txtPW2.Text = ""
    LoadcboStyle
    cboStyle.ListIndex = j - 1
    
    lbPW.Visible = True
    cmdOK.caption = "修改"
    freItem.caption = " 修改用户 "
    ShowItemFrame True
    txtUser.SetFocus
Exit Sub
aaaa:
    MsgBox Err.Description, vbCritical
End Sub

Private Sub cmdExit_Click()
    ShowItemFrame False
    List1.SetFocus
End Sub

Private Sub cmdOK_Click()
On Error GoTo aaaa
    If txtUser.Text = "" Then
        MsgBox "必须填写用户名。", vbInformation
        txtUser.SetFocus
        Exit Sub
    End If
    If cmdOK.caption = "添加" Then
        If txtPW.Text = "" Then
            MsgBox "必须填写密码。", vbInformation
            txtPW.SetFocus
            Exit Sub
        End If
        If txtPW2.Text = "" Then
            MsgBox "必须填写确认密码。", vbInformation
            txtPW2.SetFocus
            Exit Sub
        End If
    End If
    If txtPW.Text <> txtPW2.Text Then
        MsgBox "密码前后不一致。", vbInformation
        txtPW2.SetFocus
        Exit Sub
    End If
    If cmdOK.caption = "添加" Then
        cnMain.Execute "insert [User] values('" & txtUser.Text & "','" & GetMD5(txtPW.Text) & "'," & CStr(cboStyle.ListIndex + 1) & ")"
        LoadUserList
        SetSB 2, "添加用户 " & txtUser.Text & " 成功."
    Else
        If txtPW.Text = "" Then
            cnMain.Execute "UPDATE [User] SET UserName='" & txtUser.Text & "',UserStyle=" & CStr(cboStyle.ListIndex + 1) & " Where UserName='" & txtUser.Tag & "'"
        Else
            cnMain.Execute "UPDATE [User] SET UserName='" & txtUser.Text & "',UserPW='" & GetMD5(txtPW.Text) & "',UserStyle=" & CStr(cboStyle.ListIndex + 1) & " Where UserName='" & txtUser.Tag & "'"
        End If
        List1.SelectedItem.SubItems(1) = txtUser.Text
        List1.SelectedItem.SubItems(2) = cboStyle.Text
        SetSB 2, "修改用户 " & txtUser.Text & " 成功."
    End If
    cmdExit_Click
Exit Sub
aaaa:
    MsgBox "操作失败，可能是该用户名已经存在！", vbCritical
End Sub

Private Sub Form_Load()
    Me.WindowState = 2
    imgIcon.Picture = frmMain.cmdLeft(6).Picture
    '读取用户数据列表
    LoadUserList
End Sub

'加载cboStyle
Private Sub LoadcboStyle()
    Dim i As Long
    cboStyle.Clear
    For i = 1 To 4
        If i <= 2 Or curUserStyle = 4 Then cboStyle.AddItem i & "－" & GetUserStyleString(i)
    Next
End Sub

'读取用户数据列表
Public Sub LoadUserList()
    Dim Item As ListItem, lngUserStyle As Long
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    List1.ListItems.Clear
    rs.Open "Select * From [User] order by UserID Desc", cnMain, 1, 1
    Do Until rs.EOF
        lngUserStyle = rs("UserStyle")
        Set Item = List1.ListItems.Add(, , rs("UserID"), , lngUserStyle)
        Item.SubItems(1) = rs("UserName")
        Item.SubItems(2) = lngUserStyle & "－" & GetUserStyleString(lngUserStyle)
        rs.MoveNext
    Loop
    SetSB 2, "共 " & rs.RecordCount & " 条用户员记录."
End Sub

Public Function GetUserStyleString(ByVal lngUserStyle As Long) As String
    Select Case lngUserStyle
    Case 1
        GetUserStyleString = "员工"
    Case 2
        GetUserStyleString = "初级管理员"
    Case 3
        GetUserStyleString = "中级管理员"
    Case 4
        GetUserStyleString = "高级管理员"
    End Select
End Function

Public Sub ShowItemFrame(ByVal b As Boolean)
    List1.Visible = Not b
    freItem.Visible = b
    cmdDel.Enabled = Not b
    cmdEdit.Enabled = Not b
    cmdAdd.Enabled = Not b
End Sub

Private Sub Form_Resize()
On Error Resume Next
    List1.Width = Width / 15 - 40
    List1.Height = Height / 15 - 116
    PicTop.Width = Width / 15 - 16
    Cls
    Line (2, 2)-(Width / 15 - 14, Height / 15 - 29), 10921638, B
End Sub

Private Sub List1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
On Error Resume Next
    With List1
        If (ColumnHeader.Index - 1) = .SortKey Then
            .SortOrder = 1 - .SortOrder
            .Sorted = True
        Else
            .Sorted = False
            .SortOrder = 0
            .SortKey = ColumnHeader.Index - 1
            .Sorted = True
        End If
    End With
End Sub

Private Sub List1_DblClick()
On Error GoTo aaaa
    Dim j As Long
    j = List1.SelectedItem.Index
    cmdEdit_Click
aaaa:
End Sub

Private Sub List1_KeyDown(KeyCode As Integer, Shift As Integer)
On Error GoTo aaaa
    If KeyCode = vbKeyDelete Then
        Dim j As Long
        j = List1.SelectedItem.Index
        cmdDel_Click
    End If
aaaa:
End Sub