frmoperator.frm

专卖店POS系统,比较有使用价值.

  Set Db = OpenDatabase(ConData, False, False, ConStr)
  Set EF = Db.OpenRecordset("User", dbOpenDynaset)
      RecStr = "UserName='" & Trim(Text1.Text) & "'"
      EF.FindFirst RecStr
   If Not EF.NoMatch Then
      EF.Close
      Db.Close
      MsgBox "操作员< " & Trim(Text1.Text) & " >已经存在,不能继续!    ", vbInformation
      Text1.Text = ""
      Text1.SetFocus
      Exit Sub
   End If
      EF.Close
      Db.Close
'UserText = Text1.Text
'保存
'如果要加密的话，请将 Text2.text 的文本加密!
'别忘记在登录时，要进行解密!
 ' 插入记录
   Set Db = OpenDatabase(ConData, False, False, ConStr)
      RecStr = "Insert into User (Username,Password) values('" & Trim(Text1.Text) & "','" & Trim(Text2.Text) & "')"
      Db.Execute RecStr
      Db.Close
   ConfigGrid
   
 Text1.Text = ""
 Text2.Text = ""
 Text3.Text = ""
 Text1.SetFocus
 End Sub

Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Form_Load()

On Error Resume Next

'配置网格
Grid1.Visible = False
Grid1.Cols = 2
Grid1.FormatString = "^ 操作员 |^  口令 "
Grid1.ColWidth(0) = 800
Grid1.ColWidth(1) = 1210
Dim Db As Database, EF As Recordset, HH As Integer
  
  Set Db = OpenDatabase(ConData, False, False, ConStr)
    Set EF = Db.OpenRecordset("User", dbOpenTable)
        DelNO = EF.RecordCount
        Grid1.Rows = EF.RecordCount + 4
    Set EF = Db.OpenRecordset("Select * From User", dbOpenDynaset)
        HH = 1
        Do While Not EF.EOF()
           Grid1.Row = HH
           Grid1.Col = 0
           Grid1.CellAlignment = 1
        If Not IsNull(EF.Fields(0).Value) Then
           Grid1.Text = EF.Fields(0).Value
           UserStr = Grid1.Text
        End If
           Grid1.Row = HH
           Grid1.Col = 1
           Grid1.CellAlignment = 1
        If Not IsNull(EF.Fields(1).Value) Then
               Grid1.Text = Trim(EF.Fields(1).Value)
        End If
          EF.MoveNext
          HH = HH + 1
        Loop
        Db.Close
 Grid1.Col = 0
 Grid1.Row = 1
 Grid1.ColSel = 1
 Grid1.Visible = True
End Sub


Private Sub Grid1_DblClick()
 
 If Grid1.Text = "" Then
    MnuDelete.Enabled = False
    MnuAuthority.Enabled = False
    cmdModify.Enabled = False
    mnuModify.Enabled = False
 Else
    MnuDelete.Enabled = True
    If Grid1.Text = "超级用户" Then
      '超级用户无须权限
      MnuAuthority.Enabled = False
    Else
      MnuAuthority.Enabled = True
    End If
    mnuModify.Enabled = True
    cmdModify.Enabled = True
 End If
 
 PopupMenu MnuOperate
 
End Sub

Private Sub Grid1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)


 If Grid1.Text = "" Then
    MnuDelete.Enabled = False
    MnuAuthority.Enabled = False
    mnuModify.Enabled = False
    cmdModify.Enabled = False
 Else
    MnuDelete.Enabled = True
    MnuAuthority.Enabled = True
    mnuModify.Enabled = True
    cmdModify.Enabled = True
 End If
 
 If Button = 2 Then
    PopupMenu MnuOperate
 End If
 
End Sub

Private Sub MnuAuthority_Click()

 Me.MousePointer = 11
    frmAuthority.Show 1
 Me.MousePointer = 0
 
End Sub

Private Sub MnuDelete_Click()

 DeleteRecord
 
End Sub

Private Sub mnuModify_Click()

  cmdModify_Click
  
End Sub

Private Sub MnuReturn_Click()

 Unload Me
 
End Sub

Private Sub Text1_Change()

If cmdModify.Caption = "修改(&M)" Then
If Trim(Text1.Text) <> "" Then
   Command1.Enabled = True
   Else
   Command1.Enabled = False
End If
End If

End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 And Trim(Text1.Text) <> "" Then
   SendKeys "{tab}"
End If
End Sub

Private Sub Text2_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
   SendKeys "{tab}"
End If
End Sub

Private Sub Text3_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
   SendKeys "{tab}"
End If
End Sub

Private Sub Text3_LostFocus()
If Trim(Text3.Text) <> Trim(Text2.Text) Then
   MsgBox "两次口令不符，请重新再来    ", vbOKOnly + 64, "口令不符"
   Text2.Text = ""
   Text3.Text = ""
   Text2.SetFocus
End If
End Sub

Private Sub DeleteRecord()

On Error Resume Next

If Grid1.Text = "" Or Grid1.MouseRow = 0 Then Exit Sub

'超级用户时
If Grid1.Text = "超级用户" Then
    MsgBox "超级用户不能删除，只能修改其密码!    ", vbOKOnly + 32, "不能删除"
    Exit Sub
End If
If DelNO = 1 Then
   MsgBox "仅剩下当前用户了,不能继续,请注意!    ", vbOKOnly + 32, "不能删除"
   Exit Sub
End If
   Dim Qp As Integer
   Qp = MsgBox("真的要删除[" & Grid1.Text & "]操作员吗（Y/N）？", vbYesNo + 16, "确认删除")
   If Qp = 7 Then
      Exit Sub
   End If
Dim Db As Database, RecStr As String
  
  Set Db = OpenDatabase(ConData, False, False, ConStr)
      RecStr = "Delete * From User Where UserName='" & Grid1.Text & "'"
      Db.Execute RecStr
      Db.Close
      
  Grid1.RemoveItem Grid1.Row
  
End Sub

Private Sub ConfigGrid()

    '配置网格
  Grid1.Visible = False
  Grid1.Clear
  Grid1.Cols = 2
  Grid1.FormatString = "^ 操作员 |^  口令 "
  Grid1.ColWidth(0) = 800
  Grid1.ColWidth(1) = 1210
  
 Dim Db As Database
 Dim HH As Integer
        SureStr = ""
        shiftStr = ""
        shiftStrL = ""
        shiftStrR = ""
        shiftNum = 0
        ili = 0
        tempStr = ""
        Qy = 0
  
  Set Db = OpenDatabase(ConData, False, False, ConStr)
    Set EF = Db.OpenRecordset("User", dbOpenTable)
        DelNO = EF.RecordCount
        Grid1.Rows = EF.RecordCount + 4
    Set EF = Db.OpenRecordset("Select * From User", dbOpenDynaset)
        HH = 1
        Do While Not EF.EOF()
           Grid1.Row = HH
           Grid1.Col = 0
           Grid1.CellAlignment = 1
        If Not IsNull(EF.Fields(0).Value) Then
           Grid1.Text = EF.Fields(0).Value
           UserStr = Grid1.Text
        End If
           Grid1.Row = HH
           Grid1.Col = 1
           Grid1.CellAlignment = 1
        If Not IsNull(EF.Fields(1).Value) Then
           Grid1.Text = Trim(EF.Fields(1).Value)
        End If
          EF.MoveNext
          HH = HH + 1
        Loop
        Db.Close
 Grid1.Col = 0
 Grid1.Row = 1
 Grid1.ColSel = 1
 Grid1.Visible = True

End Sub

Private Sub MyUpdateRecord(sFields As String, sValues As String, sFieldsCond As String, sCond As String, sTable As String)
   
   On Error Resume Next
  
   Dim Db As Database
   Set Db = OpenDatabase(ConData, False, False, ConStr)
    Dim Mytmp As String
        Mytmp = "Update " & sTable & " Set " & sFields & "='" & sValues & "' Where " & sFieldsCond & "='" & sCond & "'"
    Db.Execute Mytmp
    Db.Close
    
End Sub