frmsys.frm

智能仓库管理系统

            Top             =   3300
            Width           =   885
         End
         Begin VB.CommandButton cmdExit 
            Caption         =   "退出"
            Height          =   810
            Left            =   3330
            Picture         =   "FrmSys.frx":4120
            Style           =   1  'Graphical
            TabIndex        =   6
            Top             =   3300
            Width           =   900
         End
         Begin VB.TextBox txtNewPWD1 
            BeginProperty Font 
               Name            =   "Symbol"
               Size            =   9
               Charset         =   2
               Weight          =   400
               Underline       =   0   'False
               Italic          =   0   'False
               Strikethrough   =   0   'False
            EndProperty
            Height          =   276
            IMEMode         =   3  'DISABLE
            Left            =   2340
            PasswordChar    =   "*"
            TabIndex        =   3
            Top             =   2130
            Width           =   2136
         End
         Begin VB.TextBox txtNewPWD2 
            BeginProperty Font 
               Name            =   "Symbol"
               Size            =   9
               Charset         =   2
               Weight          =   400
               Underline       =   0   'False
               Italic          =   0   'False
               Strikethrough   =   0   'False
            EndProperty
            Height          =   276
            IMEMode         =   3  'DISABLE
            Left            =   2340
            PasswordChar    =   "*"
            TabIndex        =   4
            Top             =   2505
            Width           =   2136
         End
         Begin VB.TextBox txtUser1 
            Height          =   276
            Left            =   2340
            TabIndex        =   1
            Top             =   990
            Width           =   2136
         End
         Begin VB.TextBox txtPurview1 
            Enabled         =   0   'False
            Height          =   276
            Left            =   2340
            TabIndex        =   23
            Top             =   1395
            Width           =   2136
         End
         Begin VB.TextBox TxtOldPWD2 
            BeginProperty Font 
               Name            =   "Symbol"
               Size            =   9
               Charset         =   2
               Weight          =   400
               Underline       =   0   'False
               Italic          =   0   'False
               Strikethrough   =   0   'False
            EndProperty
            Height          =   276
            IMEMode         =   3  'DISABLE
            Left            =   2340
            PasswordChar    =   "*"
            TabIndex        =   2
            Top             =   1755
            Width           =   2136
         End
         Begin VB.Label Label4 
            Caption         =   "确认密码："
            Height          =   330
            Left            =   1515
            TabIndex        =   28
            Top             =   2550
            Width           =   1335
         End
         Begin VB.Label Label5 
            Caption         =   "新密码："
            Height          =   330
            Left            =   1515
            TabIndex        =   27
            Top             =   2160
            Width           =   1335
         End
         Begin VB.Label Label6 
            Caption         =   "用户名："
            Height          =   330
            Left            =   1515
            TabIndex        =   26
            Top             =   1005
            Width           =   1335
         End
         Begin VB.Label Label8 
            Caption         =   "权  限："
            Height          =   330
            Left            =   1500
            TabIndex        =   25
            Top             =   1425
            Width           =   1335
         End
         Begin VB.Label Label9 
            Caption         =   "老密码："
            Height          =   330
            Left            =   1515
            TabIndex        =   24
            Top             =   1770
            Width           =   1335
         End
      End
   End
End
Attribute VB_Name = "FrmSys"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private cnnDB As New ADODB.Connection
Private rs As ADODB.Recordset

Private Sub DBConnection()
    
    'cnnDB.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & gDBPath & ";Jet OLEDB:Database Password=czlxming;Persist Security Info=False"
    cnnDB.ConnectionString = "DSN=Freight"
    cnnDB.CommandTimeout = 15
    cnnDB.Open
End Sub

Private Sub cmdDelete_Click()
 Dim Trs1 As ADODB.Recordset
 On Error GoTo DeleteErr
 If txtSelectUser.Text = "" Then
  MsgBox "没有选中一个用户名", vbInformation + vbOKOnly, "提示"
  Exit Sub
 End If
 
 If txtSelectUser.Text = gUser Then
   MsgBox "选中的是当前用户，不能删除！", vbInformation + vbOKOnly, "提示"
   txtSelectUser.Text = ""
   Exit Sub
 End If
 
 Set Trs1 = New ADODB.Recordset
 Trs1.Open "Delete From Login Where USERNAME1='" & txtSelectUser.Text & "'", cnnDB, adOpenKeyset, adLockOptimistic
 Trs1.Open "Delete From 权限 Where UserID='" & txtSelectUser.Text & "'", cnnDB, adOpenKeyset, adLockOptimistic
 Set Trs1 = Nothing
 MsgBox "该用户已被删除！", vbInformation + vbOKOnly, "提示"
 Call SetList
 txtSelectUser.Text = ""
 Exit Sub
DeleteErr:
  MsgBox Err.Number & "--" & Err.Description
End Sub

Private Sub cmdEdit_Click()
 Dim NewPWD As String
 Dim Trs3 As ADODB.Recordset
 Set Trs3 = New ADODB.Recordset
 On Error GoTo EditErr
 If txtUser1.Text = "" Then
  MsgBox "用户名不能为空，请输入一个用户名称", vbInformation + vbOKOnly, "提示"
  txtUser1.SetFocus
  Exit Sub
 End If
 
 Trs3.Open "Select USERNAME1 From Login where ID <> " & txtID.Text & "", cnnDB, adOpenStatic, adLockReadOnly
 Do While Not Trs3.EOF
   If UCase(txtUser1.Text) = Trs3("USERNAME1") Then
    MsgBox "该用户名已经存在，请输入另外一个用户名称！", vbInformation + vbOKOnly, "提示"
    Trs3.Close
    txtUser1.SetFocus
    Exit Sub
   Else
    Trs3.MoveNext
   End If
 Loop
 Trs3.Close
 
 If EnString(UCase(TxtOldPWD2.Text)) <> txtOldPWD1.Text Then
  MsgBox "密码不正确！", vbInformation + vbOKOnly, "提示"
  TxtOldPWD2.SetFocus
  Exit Sub
 End If
 
 If txtNewPWD1.Text = "" Then
  MsgBox "密码不能为空！", vbInformation + vbOKOnly, "提示"
  txtNewPWD1.SetFocus
  Exit Sub
 End If
 
 If UCase(txtNewPWD1.Text) <> UCase(txtNewPWD2.Text) Then
  MsgBox "新密码输入前后不一致！", vbInformation + vbOKOnly, "提示"
  txtNewPWD2.SetFocus
  Exit Sub
 End If
 
 Set rs = New ADODB.Recordset
 NewPWD = EnString(UCase(txtNewPWD1.Text))
            StrSQL = "Update Login Set USERNAME1='" & UCase(txtUser1.Text) & "',PASSWORD1='" & NewPWD & "' Where ID=" & txtID.Text & ""
            rs.Open StrSQL, cnnDB
            MsgBox "修改用户密码成功。", vbInformation + vbOKOnly, "提示"
            TxtOldPWD2.Text = ""
            txtNewPWD1.Text = ""
            txtNewPWD2.Text = ""
            txtOldPWD1.Text = NewPWD
            gUser = UCase(txtUser1.Text)
            frmMain.MainBar.Panels(2).Text = "操作员：" & gUser
            Exit Sub
EditErr:
 MsgBox Err.Number & "--" & Err.Description
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub
Private Sub cmdExit1_Click()
 Unload Me
End Sub

Private Sub cmdExit2_Click()
 Unload Me
End Sub

Private Sub cmdExit3_Click()
 Unload Me
End Sub

Private Sub cmdNew_Click()
 Dim mPWD As String
 Dim mPurView As String
 Dim Trs4 As ADODB.Recordset
 On Error GoTo NewErr
 
 If txtUser2.Text = "" Then
  MsgBox "用户名不能为空，请输入一个用户名称", vbInformation + vbOKOnly, "提示"
  txtUser2.SetFocus
  Exit Sub
 End If
 Set Trs4 = New ADODB.Recordset
 Trs4.Open "Select USERNAME1 From Login ", cnnDB, adOpenStatic, adLockReadOnly
 Do While Not Trs4.EOF
   If UCase(txtUser2.Text) = Trs4("USERNAME1") Then
    MsgBox "该用户名已经存在，请输入另外一个用户名称！", vbInformation + vbOKOnly, "提示"
    Trs4.Close
    txtUser2.SetFocus
    Exit Sub
   Else
    Trs4.MoveNext
   End If
 Loop
 Trs4.Close
 
 If txtPWD1.Text = "" Then
  MsgBox "密码不能为空！", vbInformation + vbOKOnly, "提示"
  txtPWD1.SetFocus
  Exit Sub
 End If
 
 If txtPWD1.Text <> txtPWD2.Text Then
  MsgBox "新密码输入前后不一致！", vbInformation + vbOKOnly, "提示"
  txtPWD2.SetFocus
  Exit Sub
 End If
 
   If cbPurview.Text = "" Then
    MsgBox "请选择用户的权限！", vbInformation + vbOKOnly, "提示"
    Exit Sub
   Else
    mPurView = cbPurview.Text
   End If
   
 
 Set Trs4 = New ADODB.Recordset
 mPWD = EnString(UCase(txtPWD1.Text))
            StrSQL = "Insert into Login (USERNAME1,PASSWORD1,PURVIEW) Values('" & UCase(txtUser2.Text) & "','" & mPWD & "','" & mPurView & "')"
            Trs4.Open StrSQL, cnnDB
            If cbPurview.Text = "管理员" Then
             StrSQL = "Insert into 权限 (userID,ZG_NEW,ZG_EDIT,ZG_DEL,ZG_PRINT,QC_NEW,QC_EDIT,QC_DEL,QC_PRINT) Values('" & UCase(txtUser2.Text) & "',1,1,1,1,1,1,1,1)"
            Else
             StrSQL = "Insert into 权限 (userID,ZG_NEW,ZG_EDIT,ZG_DEL,ZG_PRINT,QC_NEW,QC_EDIT,QC_DEL,QC_PRINT) Values('" & UCase(txtUser2.Text) & "',0,0,0,0,0,0,0,0)"
            End If
            Trs4.Open StrSQL, cnnDB
            MsgBox "增加新用户成功。", vbInformation + vbOKOnly, "提示"
            txtUser2.Text = ""
            txtPWD1.Text = ""
            txtPWD2.Text = ""
    Exit Sub
NewErr:
 MsgBox Err.Number & "--" & Err.Description
            
End Sub

Private Sub cmdSave_Click()
 Dim Trs4 As ADODB.Recordset
 Dim StrSQL As String
  Set Trs4 = New ADODB.Recordset
 StrSQL = "Update 权限 Set ZG_NEW=" & cheZG(0).Value & ",ZG_EDIT=" & cheZG(1).Value & ",ZG_DEL=" & cheZG(2).Value & ",ZG_PRINT=" & cheZG(3).Value & ",QC_NEW=" & cheQC(0).Value & ",QC_EDIT=" & cheQC(1).Value & ",QC_DEL=" & cheQC(2).Value & ",QC_PRINT=" & cheQC(3).Value & " Where UserID='" & UCase(txtUser.Text) & "'"
 Trs4.Open StrSQL, cnnDB
 MsgBox "修改权限成功。", vbInformation + vbOKOnly, "提示"
End Sub

Private Sub Form_Load()
    Me.MousePointer = 11
    
    On Error GoTo LoadErr
    frmMain.MainBar.Panels(2).Text = "正在加载系统设定，请稍候..."
    DBConnection
    Set rs1 = New ADODB.Recordset
    rs1.Open "select * from Login Where USERNAME1='" & gUser & "'", cnnDB, adOpenStatic, adLockOptimistic
    txtID.Text = rs1("ID")
    txtUser1.Text = rs1("USERNAME1")
    txtOldPWD1.Text = rs1("PASSWORD1")
    txtPurview1.Text = rs1("PURVIEW")
    lblPurview.Caption = rs1("PURVIEW")
    
        frmMain.MainBar.Panels(2).Text = "用户管理"
        Me.MousePointer = 0
        Exit Sub
LoadErr:
  
  MsgBox Err.Number & "--" & Err.Description
End Sub



Private Sub Form_Unload(Cancel As Integer)
    frmMain.MainBar.Panels(2).Text = ""
    cnnDB.Close
    Set cnnDB = Nothing
End Sub


Private Sub ListUserName_Click()
  txtSelectUser.Text = ListUserName.Text
End Sub


    

  


Private Sub SetList()
    Dim Trs As ADODB.Recordset
     Set Trs = New ADODB.Recordset
     Trs.Open "Select ID,USERNAME1 From Login Order By ID", cnnDB, adOpenStatic, adLockReadOnly
     ListUserName.Clear
     Do While Not Trs.EOF
       ListUserName.AddItem (Trs("USERNAME1"))
       Trs.MoveNext
     Loop
     Trs.Close
End Sub
Private Sub SetList1()
    Dim Trs As ADODB.Recordset
     Set Trs = New ADODB.Recordset
     Trs.Open "Select ID,USERNAME1 From Login Order By ID", cnnDB, adOpenStatic, adLockReadOnly
     LisUser.Clear
     Do While Not Trs.EOF
       LisUser.AddItem (Trs("USERNAME1"))
       Trs.MoveNext
     Loop
     Trs.Close
End Sub

Private Sub LisUser_Click()
 txtUser.Text = LisUser.Text
 Call SetCheck
End Sub

Private Sub SSTab1_Click(PreviousTab As Integer)
  Select Case SSTab1.Tab
   Case 0
   Case 1
    If txtPurview1.Text = "管理员" Then
      cmdNew.Enabled = True
      lblStatus.Visible = False
      fra2.Enabled = True
    Else
      cmdNew.Enabled = False
      lblStatus.Visible = True
      fra2.Enabled = False
    End If
   Case 2
    txtSelectUser.Text = ""
    If txtPurview1.Text <> "管理员" Then
      cmdDelete.Enabled = False
      lblPurview.Caption = "普通用户（没有删除其它用户的权限）"
      fra3.Enabled = False
      Exit Sub
    End If
     Call SetList
     fra3.Enabled = True
   Case 3
    If txtPurview1.Text = "管理员" Then
      cmdSave.Enabled = True
      'cmd1.Enabled = True
      Call SetList1
      lbl3.Visible = False
      fra4.Enabled = True
      SetCheckNull
    Else
      cmdSave.Enabled = False
      'cmd1.Enabled = False
      lbl3.Visible = True
      fra4.Enabled = False
    End If
  End Select
End Sub
Private Sub SetCheckNull()
 Me.cheZG(0).Value = 0
 Me.cheZG(1).Value = 0
 Me.cheZG(2).Value = 0
 Me.cheZG(3).Value = 0
 Me.cheQC(0).Value = 0
 Me.cheQC(1).Value = 0
 Me.cheQC(2).Value = 0
 Me.cheQC(3).Value = 0
End Sub
Private Sub SetCheck()
    Set rs1 = New ADODB.Recordset
    rs1.Open "select * from 权限 Where userID='" & txtUser.Text & "'", cnnDB, adOpenStatic, adLockOptimistic
    Me.cheZG(0).Value = rs1("ZG_NEW")
    Me.cheZG(1).Value = rs1("ZG_EDIT")
    Me.cheZG(2).Value = rs1("ZG_DEL")
    Me.cheZG(3).Value = rs1("ZG_PRINT")
    Me.cheQC(0).Value = rs1("QC_NEW")
    Me.cheQC(1).Value = rs1("QC_EDIT")
    Me.cheQC(2).Value = rs1("QC_DEL")
    Me.cheQC(3).Value = rs1("QC_PRINT")
End Sub