frmfk.frm

前台POS系统,VB源码.程序没有调试,

      Set rRecord = Nothing
      Set Con = Nothing
End Sub

Private Sub Reserved(KeyCode As Integer)

  Dim lRow As Integer
  Dim lCol As Integer
  
 Select Case KeyCode
 
  Case 37   '左
     Grid1.Text = txtEdit.Text
     lRow = Grid1.Row
     lCol = Grid1.Col
    If lCol = 1 Then '第一列时
       If lRow = 1 Then
          Exit Sub
         ' lRow = Grid1.Rows - 1
        Else
          lRow = Grid1.Row - 1
       End If
       If Trim(Grid1.TextMatrix(Grid1.Row, 2)) = "" Then
        Exit Sub
       End If
       lCol = Grid1.Cols - 1
     Else
       lCol = Grid1.Col - 1
    End If
    Grid1.Row = lRow
    Grid1.Col = lCol
    Grid1.ColSel = lCol
    txtEdit.Text = Grid1.Text
  Case 38  '上
    Grid1.Text = txtEdit.Text
    lRow = Grid1.Row
    lCol = Grid1.Col
    If lRow = 1 Then '最后一行
       Exit Sub
    '   lRow = Grid1.Rows - 1
     Else
       lRow = Grid1.Row - 1
    End If
    Grid1.Row = lRow
    Grid1.Col = lCol
    Grid1.ColSel = lCol
  Case 39  '右
     'If Grid1.Col = 1 And Grid1.Row >= 1 And Trim(txtEdit.Text) <> "" Then
     '   Call txtEdit_KeyPress(13)
     '   Exit Sub
     'End If
     Grid1.Text = txtEdit.Text
     lRow = Grid1.Row
     lCol = Grid1.Col
    If lCol = Grid1.Cols - 1 Then '最后一列时
          lRow = Grid1.Row + 1
       If Trim(Grid1.TextMatrix(Grid1.Row, 2)) = "" Then
          Exit Sub
       End If
       If lRow > Grid1.Rows - 1 Then
          lRow = 1
       End If
          lCol = 1
     Else
      lCol = Grid1.Col + 1
    End If
    Grid1.Row = lRow
    Grid1.Col = lCol
    Grid1.ColSel = lCol
    txtEdit.Text = Grid1.Text
  Case 40  '下
    If Trim(Grid1.TextMatrix(Grid1.Row, 2)) = "" Then
       Exit Sub
    End If
    Grid1.Text = txtEdit.Text
    lRow = Grid1.Row
    lCol = Grid1.Col
    If lRow = Grid1.Rows - 1 Then '最后一行
       lRow = 1
     Else
       lRow = Grid1.Row + 1
    End If
    Grid1.Row = lRow
    Grid1.Col = lCol
    Grid1.ColSel = lCol
  End Select
End Sub

Private Sub AcountThis()

  Dim x As Integer, y As Integer
  Dim CQua As Currency
  Dim cAmo As Currency
      CQua = 0: cAmo = 0
     For x = 1 To Grid1.Rows - 1
         For y = 1 To CodeQua
            If Trim(Grid1.TextMatrix(x, 3 + y)) <> "" Then
              CQua = CQua + CCur(Grid1.TextMatrix(x, 3 + y))
            End If
         Next
     Next
     lbQua.Caption = CQua
      For x = 1 To Grid1.Rows - 1
         If Trim(Grid1.TextMatrix(x, 5 + CodeQua)) <> "" Then
            cAmo = cAmo + CCur(Grid1.TextMatrix(x, 5 + CodeQua))
         End If
     Next
     lbAmo.Caption = cAmo
     
End Sub

Private Sub ConfigProduct(sSQL As String, bContent As Boolean)

  On Error GoTo Err_S
  Dim Con As Database
  Dim rRecord As Recordset
      Set Con = OpenDatabase(ConData, 0, 0, ConStr) '打开ODBC数据源
      Set rRecord = Con.OpenRecordset(sSQL, dbOpenDynaset)
      'rRecord.Open sSql, Con, adOpenStatic, adLockPessimistic, adCmdText
    
  If bContent = False Then
     ProductLay = 2
  '配置网格
   Grid3.Visible = False
   Grid3.Clear
   Grid3.Cols = 6 + CodeQua
   Dim sFormat As String
   Dim x As Integer
   For x = 1 To CodeQua
       sFormat = sFormat & "|<    " & CodeName(x)
   Next
   Grid3.FormatString = "..|<产品编号|<产品名称|<单位 |<单价 " & sFormat & "|<产品分类"
   Grid3.ColWidth(0) = 200
   Grid3.ColWidth(1) = 2300
   Grid3.ColWidth(2) = 3500
   Grid3.ColWidth(3) = 800
   Grid3.ColWidth(4) = 1000
   For x = 1 To CodeQua
       Grid3.ColWidth(x + 4) = 800
   Next
   Grid3.ColWidth(5 + CodeQua) = 1300
   If rRecord.BOF Or rRecord.EOF Then
      rRecord.Close
      Con.Close
      Set rRecord = Nothing
      Set Con = Nothing
   Else
      Dim GridNO As Long
      Do While Not rRecord.EOF
         GridNO = GridNO + 1
         rRecord.MoveNext
      Loop
         Grid3.BackColorSel = SelectBackColor
         Grid3.ForeColorSel = SelectForeColor
         Grid3.Rows = GridNO + 5
         If Grid3.Rows < 29 Then  '缺省的30行
            Grid3.Rows = 29
         End If
      If rRecord.BOF And rRecord.EOF Then
         Else
         rRecord.MoveFirst
             HH = 1
         Do While Not rRecord.EOF
            Grid3.Row = HH
            Grid3.Col = 1
            Grid3.CellAlignment = 1
            If Not IsNull(rRecord.Fields("GoodsID")) Then
               Grid3.Text = rRecord.Fields("GoodsID")
            End If
            Grid3.Col = 2
            Grid3.CellAlignment = 1
            If Not IsNull(rRecord.Fields("GoodsName")) Then
               Grid3.Text = rRecord.Fields("GoodsName")
            End If
            Grid3.Col = 3
            Grid3.CellAlignment = 1
            If Not IsNull(rRecord.Fields("Unit")) Then
               Grid3.Text = rRecord.Fields("Unit")
            End If
            Grid3.Col = 4
            Grid3.CellAlignment = 1
            If Not IsNull(rRecord.Fields("Price")) Then
               Grid3.Text = rRecord.Fields("Price")
            End If
            For x = 1 To CodeQua
                Grid3.Col = x + 4
                Grid3.CellAlignment = 1
                If Not IsNull(rRecord.Fields(x + 12)) Then
                   Grid3.Text = rRecord.Fields(x + 12)
                End If
            Next
            Grid3.Col = 5 + CodeQua
            Grid3.CellAlignment = 1
            If Not IsNull(rRecord.Fields("Class")) Then
               Grid3.Text = rRecord.Fields("Class")
            End If
            rRecord.MoveNext
            HH = HH + 1
         Loop
      End If
    rRecord.Close
    Con.Close
    Set rRecord = Nothing
    Set Con = Nothing
    Grid3.Row = 1
    Grid3.Col = 1
  End If
    Grid3.ColSel = 5 + CodeQua
    Grid3.Visible = True
 Else '配置Content网格
   ProductLay = 1
   Grid3.Visible = False
   Grid3.Clear
   Grid3.Cols = 2
   Grid3.FormatString = "..|^* * * * * * * * * *   产 品 分 类  * * * * * * * * * *"
   Grid3.ColWidth(0) = 200
   Grid3.ColWidth(1) = 11800

   If rRecord.BOF Or rRecord.EOF Then
      rRecord.Close
      Con.Close
      Set rRecord = Nothing
      Set Con = Nothing
   Else
      Do While Not rRecord.EOF
         GridNO = GridNO + 1
         rRecord.MoveNext
      Loop
         Grid3.BackColorSel = SelectBackColor
         Grid3.ForeColorSel = SelectForeColor
         Grid3.Rows = GridNO + 5
         If Grid3.Rows < 30 Then  '缺省的30行
            Grid3.Rows = 30
         End If
      If rRecord.BOF And rRecord.EOF Then
         Else
         rRecord.MoveFirst
             HH = 1
         Do While Not rRecord.EOF
            Grid3.Row = HH
            Grid3.Col = 1
            Grid3.CellAlignment = 4
            If Not IsNull(rRecord.Fields("Class")) Then
               Grid3.Text = rRecord.Fields("Class")
            End If
            rRecord.MoveNext
            HH = HH + 1
         Loop
      End If
    rRecord.Close
    Con.Close
    Set rRecord = Nothing
    Set Con = Nothing
    Grid3.Row = 1
    Grid3.Col = 1
  End If
    Grid3.ColSel = 1
    Grid3.Visible = True
 End If
    
   Exit Sub
Err_S:
  MsgBox "很抱歉，不能正常配置网格（或查询供应商） " & vbCrLf & vbCrLf & "：请 WWW.VB-CODE.NET,网咨询   " & vbCrLf & vbCrLf & Err.Description, vbInformation, "Error for form load."
  Exit Sub

End Sub

Private Sub CreateOrder()

    ' 确定日期
    Dim DateStr
    Dim sYear
    Dim sMonth
    Dim sDate
    sYear = Year(Date)    '年
    sMonth = Month(Date)  '月
    sDate = Day(Date)     '日
      sYear = Right(sYear, 2)
   If Len(sMonth) = 1 Then
      sMonth = "0" & sMonth
   End If
   If Len(sDate) = 1 Then
      sDate = "0" & sDate
   End If
  
    On Error Resume Next
   ' dim Con as database
   'set con=opendatabase(condata,0,0,constr)
       '
  Dim Con As Database
  Dim rRecord As Recordset
  Set Con = OpenDatabase(ConData, 0, 0, ConStr)
  Set rRecord = Con.OpenRecordset(sSQL, dbOpenDynaset)
       
       DBEngine.BeginTrans
      Dim SQLClass As String
        SQLClass = "Select * From SheetNo Where Date=#" & Date & "# And SheeName='AccSheet'"
       Dim LX
       Set rsClass = Con.OpenRecordset(SQLClass, dbOpenDynaset)
       ' rsClass.Open SQLClass, CN, adOpenStatic, adLockPessimistic, adCmdText
   If rsClass.BOF And rsClass.EOF Then 'Add recordset
        LX = 1
        rsClass.AddNew
        rsClass.Fields("SheeName") = "AccSheet"
        rsClass.Fields("SheetID") = LX
        rsClass.Fields("Date") = Date
        rsClass.Update
      Else  'Update recordet
        LX = CLng(rsClass("SheetID")) + 1
        rsClass.Fields("SheetID") = LX
        rsClass.Fields("Date") = Date
        rsClass.Update
     End If
     If Len(LX) = 1 Then
        DateStr = sShopID & sYear & sMonth & sDate & "AC0" & LX  '日期字符串
       Else
        DateStr = sShopID & sYear & sMonth & sDate & "AC" & LX  '日期字符串
     End If
        Dim rsOrder As Recordset
            '建立付款单
            SQLClass = "Select * From account"
            Set rsOrder = Con.OpenRecordset(SQLClass, dbOpenDynaset)
            'rsOrder.Open SQLClass, CN, adOpenStatic, adLockPessimistic, adCmdText
            rsOrder.AddNew
            rsOrder.Fields("AccSheetID") = DateStr
            rsOrder.Fields("Type") = "付款单"
            rsOrder.Fields("Summary") = "付款到[]"
            rsOrder.Fields("DAte") = dpDate.Value
            rsOrder.Update
     rsClass.Close
     rsOrder.Close
     DBEngine.CommitTrans
     Con.Close
     Set rsClass = Nothing
     Set rsOrder = Nothing
     Set Con = Nothing
     txtUnitID.Enabled = True
     cmdSelectGuest.Enabled = True
     dpDate.Enabled = True
     txtFK.Enabled = True
     txtFK.Text = 0
     txtUnitID.SetFocus
     lbSheetID.Caption = DateStr
     tbOrder.Buttons(2).Enabled = True
     tbOrder.Buttons(6).Enabled = True
     tbOrder.Buttons(8).Enabled = True
     imgStatus.Picture = imgDraft.Picture
     txtUnitID.Text = ""
     lbUnit.Caption = ""
     
End Sub

Private Sub SaveRecord(bCheck As Boolean)
  
   If Trim(lbSheetID.Caption) = "" Then Exit Sub
   If bCheck = False Then
    'dim Con as database
    'set con=opendatabase(condata,0,0,constr)
    '
  Dim Con As Database
  Set Con = OpenDatabase(ConData, 0, 0, ConStr)
        DBEngine.BeginTrans
    Dim SQLClass As String
   '1. update 付款单
        SQLClass = "Select * From account Where AccSheetID='" & lbSheetID & "'"
        Set rsClass = Con.OpenRecordset(SQLClass, dbOpenDynaset)
        'rsClass.Open SQLClass, CN, adOpenStatic, adLockPessimistic, adCmdText
        rsClass.Edit
        rsClass.Fields("UnitID") = Trim(txtUnitID.Text)
        rsClass.Fields("UnitName") = lbUnit.Caption
        If txtFK.Text = "" Then txtFK.Text = 0
        rsClass.Fields("FKAmo") = CCur(txtFK.Text)
        'rsClass.Fields("YEAmo") = rsClass.Fields("YEAmo") - CCur(txtFK.Text)
        rsClass.Fields("Summary") = "付款到[" & lbUnit.Caption & "]"
        rsClass.Fields("Date") = dpDate.Value
        rsClass.Fields("Operator") = sUserName
        rsClass.Update
        rsClass.Close
     DBEngine.CommitTrans
     Con.Close
     Set rslclass = Nothing
     Set C0N = Nothing
    Else
      If Trim(txtUnitID.Text) = "" Then
         MsgBox "对不起，请填写[供应商]名称后继续！   ", vbInformation
         txtUnitID.SetFocus
         Exit Sub
      End If
         If Trim(txtFK.Text) = "" Then txtFK.Text = 0
      If CCur(txtFK.Text) = 0 Then
         MsgBox "对不起，付款金额为零时不能生效。 ", vbInformation
         Exit Sub
      End If
      If MsgBox("付款单生效后，将不能修改，是否确认（Y/N）？   ", vbInformation + vbYesNo) = vbNo Then
         Exit Sub
      End If
  '          set con=opendatabase(condata,0,0,constr)
  '