frmcustomer.frm

机房管理

        End If
          Ef.MoveNext
          HH = HH + 1
        Loop
        Ef.Close
        DB.Close
 Grid1.Col = 1
 Grid1.Row = 1
 Grid1.ColSel = 5
 Grid1.Visible = True
 Exit Sub
Err_grid:
 MsgBox "网格 配置错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Sub cmdDel_Click()
 
  On Error GoTo Err_del
  If Grid1.Text = "" Then
     txtDW = ""
     txtDJ = ""
     cmbPM.SetFocus
     'MsgBox "请选定要删除的物品！    ", vbInformation
     Exit Sub
  End If
    
  If MsgBox("真的要删除 [ " & Grid1.Text & " ] 吗（Y/N）？    ", vbYesNo + vbCritical) = vbYes Then
     DelRecord Grid1.TextMatrix(Grid1.Row, 0), "ID", "Customer"
     sJE = sJE - Val(Grid1.TextMatrix(Grid1.Row, 4))  '金额下调
     Grid1.RemoveItem Grid1.Row
  End If
  
  txtDW = ""
  txtDJ = ""
  cmbPM.SetFocus
  
  Exit Sub
Err_del:
 MsgBox "删除记录错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Sub cmdPast_Click()

  On Error GoTo Err_
  If Grid1.Text = "" Or Grid1.TextMatrix(Grid1.Row, 5) = "已送" Then
     MsgBox "请选定已点而未送的物品！    ", vbInformation
     cmbPM.SetFocus
     Exit Sub
  End If
  ' 更改未送为已送
    PastRecord CLng(Grid1.TextMatrix(Grid1.Row, 0)), "ID" '更新数据库
    sJE = sJE + Grid1.TextMatrix(Grid1.Row, 4)  '金额增加
    
    Grid1.Col = 0
    Grid1.CellForeColor = &H8000&
    Grid1.Col = 1
    Grid1.CellForeColor = &H8000&
    Grid1.Col = 2
    Grid1.CellForeColor = &H8000&
    Grid1.Col = 3
    Grid1.CellForeColor = &H8000&
    Grid1.Col = 4
    Grid1.CellForeColor = &H8000&
    Grid1.Col = 5
    Grid1.CellForeColor = &H8000&
    Grid1.Text = "已送"   '更新网格
    Grid1.Col = 1
    Grid1.ColSel = 5
    cmbPM.SetFocus
    Exit Sub
    
Err_:
    MsgBox "未知错误：" & vbCrLf & vbCrLf & Err.Description, vbOKOnly
    
End Sub

Private Sub Form_Activate()

  cmbPM.SetFocus
  
End Sub


Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

  If KeyCode = 46 Then 'Del
  
     If Grid1.Text = "" Then Exit Sub
     
     If Shift = 1 Then  'Shift按下时,直接删除
        DelRecord Grid1.TextMatrix(Grid1.Row, 0), "ID", "Customer"
        sJE = sJE - Val(Grid1.TextMatrix(Grid1.Row, 4))  '金额下调
        Grid1.RemoveItem Grid1.Row
        Exit Sub
     End If
     
       '执行删除询问
       cmdDel.Value = True

  End If
  
End Sub

Private Sub Form_Load()

 FCT = True
 
 On Error GoTo Err_init
  Screen.MousePointer = 11
  Dim L As Long, T As Long
  L = Val(GetSetting(App.EXEName, "Option", "Customer_L", 2000))
  T = Val(GetSetting(App.EXEName, "Option", "Customer_T", 2000))
  Me.left = L
  Me.tOp = T
  Me.Caption = sJH & " 消费列表 ： 现在是 [ " & Format(Date, "yyyy/mm/dd") & "  " & Time & " ] "
  
  txtJH = sJH    '消费房号
  ConfigGrid
  ConfigPM       '配置品名
  Screen.MousePointer = 0
  
  Exit Sub
Err_init:
 MsgBox "表单初始化错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Sub ConfigPM()

 On Error GoTo Err_PM
Dim DB As Database, Ef As Recordset
    Set DB = OpenDatabase(ConData, False, False, ConStr)
    'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
    
    Set Ef = DB.OpenRecordset("EatList", dbOpenTable)
        
    Do While Not Ef.EOF
      If Not IsNull(Ef.Fields(1)) Then cmbPM.AddItem Ef.Fields(1)
      Ef.MoveNext
    Loop
 
  Ef.Close
  DB.Close
  'If cmbPM.ListCount > 0 Then cmbPM.ListIndex = 0  '取消物品列表
   Exit Sub
Err_PM:
 MsgBox "品名配置错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Function GetDJ(sPM As String) As Currency

   On Error GoTo Err_dj
   Dim DB As Database, Ef As Recordset
    Set DB = OpenDatabase(ConData, False, False, ConStr)
    'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
    
    Set Ef = DB.OpenRecordset("Select * From EatList Where 名称='" & sPM & "'", dbOpenDynaset)
        
        If Ef.BOF And Ef.EOF Then
           GetDJ = 0
         Else
           If Not IsNull(Ef.Fields(3)) Then GetDJ = Ef.Fields(3)
           If Not IsNull(Ef.Fields(2)) Then sDW = Ef.Fields(2)  '给出单位
        End If
         
    Ef.Close
    DB.Close
      Exit Function
Err_dj:
 MsgBox "给出单价错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Function

Private Sub Form_Unload(Cancel As Integer)

  FCT = False
  
  On Error GoTo Err_Load
 ' 更新操作
  frmServer.lvComputer.ListItems(Val(sJH)).SubItems(7) = sJE
 
 ' 保存操作
  AppName = Val(sJH)
  KeyName = "OtherXF"
  Value = sJE
  WriteInI     '写数据
         
  SaveSetting App.EXEName, "Option", "Customer_L", Me.left
  SaveSetting App.EXEName, "Option", "Customer_T", Me.tOp
  Exit Sub
Err_Load:
 MsgBox "表单御载错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub


Private Sub txtDJ_GotFocus()
   
   txtDJ.SelStart = 0
   txtDJ.SelLength = Len(txtDJ)
   
End Sub

Private Sub txtDJ_KeyPress(KeyAscii As Integer)

   If (KeyAscii > 47 And KeyAscii < 58) Or KeyAscii = 8 Then
     Exit Sub
   ElseIf KeyAscii = 13 Then
       SendKeys "{tab}"
    ElseIf KeyAscii = 43 Then
       KeyAscii = 0
       cmdAdd.Value = True
      Else
       KeyAscii = 0
   End If

End Sub

Private Sub txtDJ_LostFocus()
  
  If Val(txtDJ) = 0 Then
     txtDJ = sDJ
  End If

End Sub

Private Sub txtSL_GotFocus()

   txtSL.SelStart = 0
   txtSL.SelLength = Len(txtSL)
   
End Sub

Private Sub txtSL_KeyDown(KeyCode As Integer, Shift As Integer)

  If KeyCode = 40 Then  ' 向上
     txtSL = txtSL + 1
  End If
  If KeyCode = 38 Then ' 向下
     If txtSL > 1 Then txtSL = txtSL - 1
  End If
  
  ' 选定
  If KeyCode >= 96 And KeyCode <= 105 Then
    Else
    KeyCode = 0
     txtSL.SelStart = 0
    txtSL.SelLength = Len(txtSL)
  End If

    
End Sub

Private Sub txtSL_KeyPress(KeyAscii As Integer)

   If (KeyAscii > 47 And KeyAscii < 58) Or KeyAscii = 8 Then
     Exit Sub
   ElseIf KeyAscii = 13 Then
      If Val(txtSL) > 0 Then
         cmdAdd.Value = True  ' 添加
         KeyAscii = 0
      End If
    ElseIf KeyAscii = 43 Then '+时
      KeyAscii = 0
      cmdAdd.Value = True
     Else
     KeyAscii = 0
   End If

End Sub

Private Sub txtSL_LostFocus()

  If Val(txtSL) = 0 Then
     txtSL = "1"
  End If
  
End Sub

Private Sub DelRecord(sWP As String, sFields As String, sTable As String)

   On Error GoTo Err_del
   Dim DB As Database
   Dim sEXE As String
   
   Set DB = OpenDatabase(ConData, False, False, ConStr)
   'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
   
   ' SQL语言删除
     sEXE = "Delete * From " & sTable & " Where " & sFields & "=" & sWP
     DBEngine.BeginTrans     ' 进行事务操作
     DB.Execute sEXE
     DBEngine.CommitTrans
     DB.Close
        Exit Sub
Err_del:
 MsgBox "删除记录错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Sub AddRecord(sWP1 As String, sFields1 As String, sWP2 As String, sFields2 As String, _
     sWP3 As String, sFields3 As String, sWP4 As String, sFields4 As String, sWP5 As String, sFields5 As String, sWP6 As String, sFields6 As String, sTable As String)

   'On Error GoTo Err_Add
   Dim DB As Database
   Dim sEXE As String
   
   Set DB = OpenDatabase(ConData, False, False, ConStr)
   'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
   
   ' SQL语言删除
     sEXE = "Insert into " & sTable & " (" & sFields1 & "," & sFields2 & "," & sFields3 & "," & sFields4 & "," & sFields5 & "," & sFields6 & ",状态,时间,单位) values('" _
            & sWP1 & "'," & sWP2 & "," & sWP3 & "," & sWP4 & ",'" & sWP5 & "',#" & sWP6 & "#,'已送',#" & Time() & "#,'" & sDW & "')"
     DBEngine.BeginTrans     ' 进行事务操作
     DB.Execute sEXE
     DBEngine.CommitTrans
     DB.Close
        Exit Sub
Err_Add:
 MsgBox "添加记录错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Function GetPm(sPM As String) As String

   On Error GoTo Err_dj
   Dim DB As Database, Ef As Recordset
    Set DB = OpenDatabase(ConData, False, False, ConStr)
    'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
    
    Set Ef = DB.OpenRecordset("Select * From EatList Where 名称='" & sPM & "'", dbOpenDynaset)
        
        If Ef.BOF And Ef.EOF Then
           GetPm = ""
         Else
           If Not IsNull(Ef.Fields(1).Value) Then
              GetPm = Ef.Fields(1).Value
           End If
        End If
         
    Ef.Close
    DB.Close
      Exit Function
Err_dj:
 MsgBox "给出名称错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Function

Private Function GetCode(sPM As String) As String

   On Error GoTo Err_dj
   Dim DB As Database, Ef As Recordset
    Set DB = OpenDatabase(ConData, False, False, ConStr)
    'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
    
    Set Ef = DB.OpenRecordset("Select * From EatList Where 代码='" & sPM & "'", dbOpenDynaset)
        
        If Ef.BOF And Ef.EOF Then
           GetCode = ""
         Else
           If Not IsNull(Ef.Fields(1).Value) Then
              GetCode = Ef.Fields(1).Value
           End If
        End If
         
    Ef.Close
    DB.Close
      Exit Function
Err_dj:
 MsgBox "给出代码错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Function

Private Sub PastRecord(ID As Long, sFields As String)

   On Error GoTo Err_del
   Dim DB As Database
   Dim sEXE As String
   
   Set DB = OpenDatabase(ConData, False, False, ConStr)
   'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
      
   ' SQL语言删除
     sEXE = "Update Customer Set 状态='已送' Where " & sFields & "=" & ID
     DBEngine.BeginTrans     ' 进行事务操作
     DB.Execute sEXE
     DBEngine.CommitTrans
     DB.Close
        Exit Sub
Err_del:
 MsgBox "更新已送错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub