frmcustomer.frm

一套比较全面的茶馆控制系统软件源代码

         sTmp = MsgBox("对不起，您已经添加物品了，是否入库。  " & vbCrLf & vbCrLf & "    如果不入库将不保存刚才所输入的内容，按(N)；否则保存，按(Y)？  ", vbInformation + vbYesNoCancel, "提示：By Yusilong")
     Select Case sTmp
       Case vbYes
        cmdPast.Value = True  '保存
        Unload Me
       Case vbNo
        '删除临时文件
        DeleteRecord "tmpEnterList"
        Unload Me
       Case vbCancel
        Exit Sub
     End Select
   Else
     Unload Me
  End If
    
End Sub

Private Sub ConfigGrid()

On Error GoTo Err_grid
sJE = 0
Grid1.Visible = False
Grid1.Clear
Grid1.Cols = 8
Grid1.FormatString = "^ .. |^ 物品类别 |^ 物品名称 |^ 单价 |^ 单位 |^ 数量 |^ 金额 |^ 日期 "
Grid1.ColWidth(0) = 800
Grid1.ColWidth(1) = 2000
Grid1.ColWidth(2) = 3000
Grid1.ColWidth(3) = 1200
Grid1.ColWidth(4) = 1200
Grid1.ColWidth(5) = 1200
Grid1.ColWidth(6) = 1200
Grid1.ColWidth(7) = 1150

Dim GridColor As Long

Dim DB As Database, EF As Recordset, HH As Integer, DelNO As Long
Dim shiftStr As String, shiftStrL As String, shiftStrR As String, shiftNum As Integer, ili As Integer, tempStr As String, SureStr As String, Qy As Integer
    Set DB = OpenDatabase(ConData, False, False, Constr)
    
    Set EF = DB.OpenRecordset("tmpEnterList", dbOpenTable)
        DelNO = EF.RecordCount
        Grid1.Rows = EF.RecordCount + 2
    Set EF = DB.OpenRecordset("Select * From tmpEnterList", dbOpenDynaset)
        HH = 1
        Do While Not EF.EOF()
           Grid1.Row = HH
           Grid1.Col = 0
           Grid1.CellAlignment = 4
           Grid1.CellForeColor = GridColor
        If Not IsNull(EF.Fields(0).Value) Then
           Grid1.Text = EF.Fields(0).Value
        End If
           Grid1.Row = HH
           Grid1.Col = 1
           Grid1.CellAlignment = 1
           Grid1.CellForeColor = GridColor
        If Not IsNull(EF.Fields(1).Value) Then
           Grid1.Text = EF.Fields(1).Value
        End If
           Grid1.Row = HH
           Grid1.Col = 2
           Grid1.CellAlignment = 1
           Grid1.CellForeColor = GridColor
        If Not IsNull(EF.Fields(3).Value) Then
           Grid1.Text = EF.Fields(3).Value
        End If
           Grid1.Row = HH
           Grid1.Col = 3
           Grid1.CellAlignment = 1
           Grid1.CellForeColor = GridColor
        If Not IsNull(EF.Fields(4).Value) Then
           Grid1.Text = EF.Fields(4).Value
        End If
           Grid1.Row = HH
           Grid1.Col = 4
           Grid1.CellAlignment = 1
           Grid1.CellForeColor = GridColor
        If Not IsNull(EF.Fields(5).Value) Then
           Grid1.Text = EF.Fields(5).Value
        End If
           Grid1.Row = HH
           Grid1.Col = 5
           Grid1.CellAlignment = 1
           Grid1.CellForeColor = GridColor
        If Not IsNull(EF.Fields(6).Value) Then
           Grid1.Text = EF.Fields(6).Value
        End If
           Grid1.Row = HH
           Grid1.Col = 6
           Grid1.CellAlignment = 1
           Grid1.CellForeColor = GridColor
        If Not IsNull(EF.Fields(7).Value) Then
           Grid1.Text = EF.Fields(7).Value
        End If
           Grid1.Row = HH
           Grid1.Col = 7
           Grid1.CellAlignment = 1
           Grid1.CellForeColor = GridColor
        If Not IsNull(EF.Fields(8).Value) Then
           Grid1.Text = EF.Fields(8).Value
        End If
        
          EF.MoveNext
          HH = HH + 1
        Loop
        EF.Close
        DB.Close
 Grid1.Col = 1
 Grid1.Row = 1
 Grid1.ColSel = 7
 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
     MsgBox "请选定要删除的物品！    ", vbInformation
     Exit Sub
  End If
    
  If MsgBox("真的要删除 [ " & Grid1.TextMatrix(Grid1.Row, 2) & " ] 吗（Y/N）？    ", vbYesNo + vbCritical) = vbYes Then
     DelRecord Grid1.TextMatrix(Grid1.Row, 0), "ID", "tmpEnterList"
     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 MsgBox("真的将此单入帐吗？(Y/N)   ", vbInformation + vbYesNo) = vbNo Then Exit Sub
  
   Dim DB As Database, EF As Recordset
    Set DB = OpenDatabase(ConData, False, False, Constr)
    Set EF = DB.OpenRecordset("Select * From tmpEnterList", dbOpenDynaset)
    
  ' 没有数据
    If EF.EOF And EF.BOF Then
       EF.Close
       DB.Close
       MsgBox "对不起，没有进货数据不能过帐？   ", vbInformation
       cmbPM.SetFocus
       Exit Sub
    End If
    
  ' 事务处理
    DBEngine.BeginTrans
    
    Dim sSql1 As String, sSql2 As String
        sSql1 = "Insert into EnterList Select * From tmpEnterList"
        sSql2 = "Delete * From tmpEnterList"
  ' 有数据时
    Dim sCode As String, HG As Recordset
    Dim sTmp As String, sTmp1 As String
    
    Set HG = DB.OpenRecordset("Select * From StoreList", dbOpenDynaset)
    Do While Not EF.EOF
       ' 增加库存记录，首先查找是否存在库存中，然后更新
         sCode = EF.Fields(2).Value
         sTmp = "代码='" & sCode & "'"
            HG.FindFirst sTmp
            If HG.NoMatch Then
               '播入记录
               sTmp1 = "Insert into StoreList Select Menutype,名称,单位,单价,金额,代码,数量 From tmpEnterList Where 代码='" & sCode & "'"
             Else
               '更新记录
               sTmp1 = "Update StoreList Set 数量=数量+" & EF.Fields("数量") & ",金额=金额+" & EF.Fields("金额") & " Where 代码='" & sCode & "'"
            End If
            DB.Execute sTmp1
      EF.MoveNext   '记录下翻
    Loop
    
      DB.Execute sSql1
      DB.Execute sSql2
    DBEngine.CommitTrans
    EF.Close
    DB.Close
    
   '清空
    cmbPM = "": txtDJ = "": txtDW = ""
    ConfigGrid
    cmbPM.SetFocus
    Exit Sub
    
Err_:
    MsgBox "未知错误：" & vbCrLf & vbCrLf & Err.Description, vbOKOnly
    
End Sub


Private Sub cmdSelectUnit_Click()

  picCatalog.Visible = True
  Grid1Type.SetFocus
  
End Sub

Private Sub Form_Activate()

  txtCatalog.SetFocus
  
End Sub

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

  If KeyCode = 27 Then 'ESC
     If picCatalog.Visible = True Then
        picCatalog.Visible = False
     End If
     If picPM.Visible = True Then
        picPM.Visible = False
     End If
     Exit Sub
  End If
  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
  
  If KeyCode = 123 Then  '确认
     cmdPast.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 & " ] "
  
  ConfigGrid
  ConfigPM txtCatalog.Text        '配置品名
  ConfigType     '配置类型
  tpDate.Value = Date
  
  Screen.MousePointer = 0
  
  Exit Sub
Err_init:
 MsgBox "表单初始化错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Sub ConfigPM(sPM As String)

   '配置网格
Grid1PM.Visible = False
Grid1PM.Cols = 1
Grid1PM.Clear
Grid1PM.FormatString = "^ 分 类 名 称 "
Grid1PM.ColWidth(0) = 2000

Dim DB As Database, EF As Recordset, HH As Integer
      
  
  Set DB = OpenDatabase(ConData, False, False, Constr)

    Set EF = DB.OpenRecordset("EatList", dbOpenTable)
        Grid1PM.Rows = EF.RecordCount + 2
        
        If Grid1PM.Rows < 20 Then
           Grid1PM.Rows = 20
        End If
        
    If Trim(sPM) = "" Then
        Set EF = DB.OpenRecordset("Select * From EatList", dbOpenDynaset)
     Else
        Set EF = DB.OpenRecordset("Select * From EatList Where Menutype='" & sPM & "'", dbOpenDynaset)
    End If
    
        HH = 0
        Grid1PM.Col = 0
        Grid1PM.CellAlignment = 4  '居中
        Grid1PM.Text = "新建..."
        HH = 1
        Do While Not EF.EOF()
           Grid1PM.Row = HH
           Grid1PM.Col = 0
           Grid1PM.CellAlignment = 1
        If Not IsNull(EF.Fields(1).Value) Then
           Grid1PM.Text = EF.Fields(1).Value
        End If
          EF.MoveNext
          HH = HH + 1
        Loop
        DB.Close
 Grid1PM.Col = 0
 Grid1PM.Row = 1
 Grid1PM.ColSel = 0
 Grid1PM.Visible = True

End Sub

Private Function GetDJ(sPM As String, sType As String) As Currency

   On Error GoTo Err_dj
   Dim DB As Database, EF As Recordset
    Set DB = OpenDatabase(ConData, False, False, Constr)
    
    Set EF = DB.OpenRecordset("Select * From EatList Where 名称='" & sPM & "' and MenuType='" & sType & "'", 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_Resize()

  If Me.WindowState = 1 Then Exit Sub
  
  On Error Resume Next
  Frame1.Width = Me.ScaleWidth - 100
  Grid1.Width = Me.ScaleWidth - 100
  Grid1.Height = Me.Height - Frame1.Height - 500
  
End Sub

Private Sub Form_Unload(Cancel As Integer)

  FCT = False
          
  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 Grid1_Click()

  If Grid1.Text = "" Then
     cmdDel.Enabled = False
     mnuDel.Enabled = False
    Else
     cmdDel.Enabled = True
     mnuDel.Enabled = True
  End If
  
End Sub

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

  If Button = 2 Then
     PopupMenu mnuOperater
  End If
  
End Sub

Private Sub Grid1PM_LostFocus()

  picPM.Visible = False
  
End Sub

Private Sub Grid1Type_Click()
  
  If Grid1Type.Text = "" Then Exit Sub
 ' 新建类别
   If Grid1Type.Text = "新建..." Then
      CunstomType1.Show 1
      '刷新数据
      ConfigType
      txtCatalog.Text = sType
      picCatalog.Visible = False
      Exit Sub
    Else
      txtCatalog.Text = Grid1Type.Text
      picCatalog.Visible = False
   End If
  
End Sub

Private Sub Grid1Type_KeyPress(KeyAscii As Integer)

If KeyAscii = 13 Then
    '关闭
    Grid1Type_Click
    picCatalog.Visible = False
 End If
 If KeyAscii = 27 Then
    picCatalog.Visible = False
 End If
 
End Sub

Private Sub Grid1Type_LostFocus()

  picCatalog.Visible = False
  
End Sub

Private Sub mnuClose_Click()