frmsaleform.frm

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

      FormID = "SL100"
      MovePic picSelectP, False, frmOrder, Grid1, Grid3
      txtEdit.Text = Grid3.TextMatrix(Grid3.Row, 1)
      Grid1.TextMatrix(Grid1.Row, 1) = Grid3.TextMatrix(Grid3.Row, 1)
      Grid1.TextMatrix(Grid1.Row, 2) = Grid3.TextMatrix(Grid3.Row, 2)
      Grid1.TextMatrix(Grid1.Row, 3) = Grid3.TextMatrix(Grid3.Row, 3)
      Dim X As Integer
      For X = 1 To CodeQua
         Grid1.TextMatrix(Grid1.Row, 3 + X) = 0
      Next
      Grid1.TextMatrix(Grid1.Row, 4 + CodeQua) = Grid3.TextMatrix(Grid3.Row, 4)
      Grid1.TextMatrix(Grid1.Row, 5 + CodeQua) = 0
      cmdSelect.Visible = False
      txtEdit.Visible = False
      Grid1.Col = 4
      Grid1.ColSel = 4
      Exit Sub
   End If
   If ProductLay = 1 Then
      ConfigProduct "Select * From Goods Where Class='" & Grid3.Text & "'", False
   End If
   
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 GoTo ErrCreate
   Dim Con As Database
   Set Con = OpenDatabase(ConData, 0, 0, ConStr)
       DBEngine.BeginTrans
    Dim SQLClass As String
        SQLClass = "Select * From SheetNo Where Date=#" & Date & "# And SheeName='SellSheet'"
       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") = "SellSheet"
        rsClass.Fields("SheetID") = LX
        rsClass.Fields("Date") = Date
        rsClass.Update
      Else  'Update recordet
        LX = CLng(rsClass("SheetID")) + 1
        'rsClass.Fields("SheeName") = "SellSheet"
        rsClass.Edit
        rsClass.Fields("SheetID") = LX
        rsClass.Fields("Date") = Date
        rsClass.Update
     End If
     If Len(LX) = 1 Then
        DateStr = sShopID & sYear & sMonth & sDate & "SL0" & LX  '日期字符串
       Else
        DateStr = sShopID & sYear & sMonth & sDate & "SL" & LX  '日期字符串
     End If
        Dim rsOrder As Recordset
            SQLClass = "Select * From SellSheet"
            Set rsOrder = Con.OpenRecordset(SQLClass, dbOpenDynaset)
            'rsOrder.Open SQLClass, CN, adOpenStatic, adLockPessimistic, adCmdText
            rsOrder.AddNew
            rsOrder.Fields("SheetID") = DateStr
            rsOrder.Fields("Operator") = sUserName
            rsOrder.Update
     rsClass.Close
     rsOrder.Close
     DBEngine.CommitTrans
     Con.Close
     Set rsClass = Nothing
     Set rsOrder = Nothing
     Set Con = Nothing
     'Restore Controls
      ConfigData
      txtEdit.Enabled = True
      cmdSelect.Enabled = True
      dpDate.Enabled = True
      lbSheetID.Caption = DateStr
      tbOrder.Buttons(3).Enabled = True
      tbOrder.Buttons(5).Enabled = True
      tbOrder.Buttons(7).Enabled = True
      txtFK.Enabled = True
      optBack.Enabled = True
      lbAmo.Caption = "0": lbQua.Caption = "0"
      txtEdit.Text = ""
      Grid1.Row = 1
      Grid1.Col = 1
      Grid1.ColSel = 1
      txtEdit.Visible = True
      txtFK.Text = 0
      cmdSelect.Visible = True
     Exit Sub
ErrCreate:
     MsgBox "建立销售单错误！  " & vbCrLf & vbCrLf & Err.Description, vbInformation
     Exit Sub
End Sub

Private Sub SaveRecord(bCheck As Boolean)

    Dim Con As Database
   
   If Trim(lbSheetID.Caption) = "" Then Exit Sub
      Grid1.Col = 1
      Grid1.ColSel = 1
      AcountThis
   If bCheck = False Then
    Else
      If Trim(txtFK.Text) = "" Then
         MsgBox "对不起，未付款！    ", vbInformation
         Exit Sub
       ElseIf CCur(txtFK.Text) = 0 Then
         MsgBox "对不起，请付清货款后继续！   ", vbInformation
         txtFK.SetFocus
         Exit Sub
         ElseIf CCur(lbZL.Caption) < 0 Then
           MsgBox "对不起，请付清货款后继续！   ", vbInformation
           txtFK.SetFocus
           Exit Sub
         ElseIf CCur(CCur(txtFK.Text) - CCur(lbAmo.Caption)) <> lbZL.Caption Then
           MsgBox "对不起，请付清货款后继续！   ", vbInformation
           txtFK.SetFocus
           Exit Sub
      End If
      If CCur(lbQua.Caption) = 0 Or CCur(lbAmo.Caption) = 0 Then
         MsgBox "对不起，销售单生效时，[金额]或[数量]不能为零（0）。  ", vbInformation
         Exit Sub
      End If
      '检查每件产品数量是否为空
      If CheckQua = False Then
         MsgBox "对不起，产品的数量不能为零（0）。   ", vbInformation
         Exit Sub
      End If
      If MsgBox("销售单生效后，将不能修改，是否确认（Y/N）？   ", vbInformation + vbYesNo) = vbNo Then
         Exit Sub
      End If
            Set Con = OpenDatabase(ConData, 0, 0, ConStr)
                
                DBEngine.BeginTrans
            '1. update sellsheet table
                    SQLClass = "Select * From sellSheet Where SheetID='" & lbSheetID & "'"
                    Set rsClass = Con.OpenRecordset(SQLClass, dbOpenDynaset)
                    'rsClass.Open SQLClass, CN, adOpenStatic, adLockPessimistic, adCmdText
                    rsClass.Edit
                    rsClass.Fields("UnitID") = "YusilongShop"
                    rsClass.Fields("UnitName") = "零售"
                    rsClass.Fields("Date") = dpDate.Value
                    rsClass.Fields("IsAcc") = 1
                    If optBack = False Then
                       rsClass.Fields("IsEnd") = 0
                       rsClass.Fields("Amo") = CCur(lbAmo.Caption)
                       rsClass.Fields("Qua") = CCur(lbQua.Caption)
                    Else
                       rsClass.Fields("IsEnd") = 1
                       rsClass.Fields("Amo") = -CCur(lbAmo.Caption)
                       rsClass.Fields("Qua") = -CCur(lbQua.Caption)
                    End If
                    rsClass.Update
                    rsClass.Close
                    Con.Execute "Delete * From sellDetail Where SheetID='" & lbSheetID.Caption & "'"
                '2. update selldetail table
                       LX = 1
                    ' 更新仓库库存
                      Dim rsStore As Recordset
                      Dim sStore As String
                    Do Until Grid1.TextMatrix(LX, 1) = ""  'GoodsID
                       sTMp = Grid1.TextMatrix(LX, 1)
                       SQLClass = "Select * From sellDetail Where SheetID='" & lbSheetID & "' And GoodsID='" & sTMp & "'"
                          Set rsClass1 = Con.OpenRecordset(SQLClass, dbOpenDynaset)
                          'rsClass1.Open SQLClass, CN, adOpenStatic, adLockPessimistic, adCmdText
                          rsClass1.AddNew
                          rsClass1.Fields("SheetID") = lbSheetID.Caption
                          rsClass1.Fields("GoodsID") = sTMp
                          rsClass1.Fields("GoodsName") = Grid1.TextMatrix(LX, 2)
                          rsClass1.Fields("Unit") = Grid1.TextMatrix(LX, 3)
                             sStore = "Select * From Goods where GoodsID='" & sTMp & "'"
                             Set rsStore = Con.OpenRecordset(sStore, dbOpenDynaset)
                               rsStore.Edit
                             'rsStore.Open sStore, CN, adOpenStatic, adLockPessimistic, adCmdText
                               Dim xQua As Long
                               For X = 1 To CodeQua
                                   If optBack.Value = False Then  '减少数量
                                      rsStore.Fields(X + 12) = rsStore.Fields(X + 12) - Val(Grid1.TextMatrix(LX, X + 3))
                                      rsClass1.Fields(X + 4) = Val(Grid1.TextMatrix(LX, X + 3))
                                   Else '增加数量
                                      rsStore.Fields(X + 12) = rsStore.Fields(X + 12) + Val(Grid1.TextMatrix(LX, X + 3))
                                      rsClass1.Fields(X + 4) = -Val(Grid1.TextMatrix(LX, X + 3))
                                   End If
                                      xQua = xQua + Val(Grid1.TextMatrix(LX, X + 3))
                               Next
                              '修改库存总数量
                                rsClass1.Fields("SumQua") = rsClass1.Fields("Qua1") + rsClass1.Fields("Qua2") + rsClass1.Fields("Qua3") + _
                                        rsClass1.Fields("Qua4") + rsClass1.Fields("Qua5") + rsClass1.Fields("Qua6") + rsClass1.Fields("Qua7") + _
                                        rsClass1.Fields("Qua8") + rsClass1.Fields("Qua9")
                                rsStore.Fields("IsTrans") = 1
                                rsStore.Fields("SumQua") = rsStore.Fields("Qua1") + rsStore.Fields("Qua2") + rsStore.Fields("Qua3") + _
                                        rsStore.Fields("Qua4") + rsStore.Fields("Qua5") + rsStore.Fields("Qua6") + rsStore.Fields("Qua7") + _
                                        rsStore.Fields("Qua8") + rsStore.Fields("Qua9")
                              '修改库存金额
                               rsStore.Fields("Amo") = rsStore.Fields("SumQua") * rsStore.Fields("Price")
                            rsStore.Update
                            rsClass1.Fields("Price") = Val(Grid1.TextMatrix(LX, 4 + CodeQua))
                            If optBack.Value = False Then
                               rsClass1.Fields("Amo") = Val(Grid1.TextMatrix(LX, 5 + CodeQua))
                              Else
                               rsClass1.Fields("Amo") = -Val(Grid1.TextMatrix(LX, 5 + CodeQua))
                            End If
                            rsClass1.Fields("Date") = dpDate.Value
                          rsClass1.Update
                          rsClass1.Close
                          rsStore.Close
                       LX = LX + 1
                       If Grid1.TextMatrix(LX, 1) = "" Then Exit Do
                      DoEvents
                    Loop
                    '减少库存
                    If optBack.Value = False Then
                       SaveAccount "收款单", lbSheetID.Caption, CCur(lbAmo.Caption), "[零售]收款单，日期:" & Date, False
                    Else
                    '如果为退货时
                       SaveAccount "退款单", lbSheetID.Caption, CCur(lbAmo.Caption), "[零售]退款单，日期:" & Date, True
                    End If
                  DBEngine.CommitTrans
                  Con.Close
                  Set rslclass = Nothing
                  Set rsClass1 = Nothing
                  Set Con = Nothing
                  txtEdit.Enabled = False
                  cmdSelect.Enabled = False
                  tbOrder.Buttons(3).Enabled = False
                  tbOrder.Buttons(7).Enabled = False
                  dpDate.Enabled = False
                  optBack.Enabled = False
                  txtFK.Enabled = False
    End If
                
End Sub

Private Sub ConfigOrder(sSQL As String)

  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
       
  '配置网格
   Grid4.Visible = False
   Grid4.Clear
   Grid4.Cols = 7
   Grid4.FormatString = "^..|^ 销售单编号 |^ 单位名称 |^ 数量 |^ 金额 |^ 状态|^日期"
   Grid4.ColWidth(0) = 200
   Grid4.ColWidth(1) = 2400
   Grid4.ColWidth(2) = 3500
   Grid4.ColWidth(3) = 1000
   Grid4.ColWidth(4) = 1000
   Grid4.ColWidth(5) = 2100
   Grid4.ColWidth(6) = 1380
   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
         Grid4.BackColorSel = SelectBackColor
         Grid4.ForeColorSel = SelectForeColor
         Grid4.Rows = GridNO + 5
         If Grid4.Rows < 29 Then  '缺省的30行
            Grid4.Rows = 29
         End If
         Dim sStatus As String
         Dim fColor As Long
         Dim bColor As Long
         Dim haveBack As Boolean
      If rRecord.BOF And rRecord.EOF Then
         Else
         rRecord.MoveFirst
             hh = 1
         Do While Not rRecord.EOF
            Grid4.Row = hh
            If haveBack = False Then
               haveBack = True
               bColor = BackColor1
             Else
               haveBack = False
               bColor = BackColor2
            End If
             If Not IsNull(rRecord.Fields("IsAcc")) Then
               If rRecord.Fields("IsAcc") = 1 And rRecord.Fields("IsEnd") = 0 Then
                  sStatus = "已经发送到总公司"
                  fColor = &H8000&
               ElseIf rRecord.Fields("IsEnd") = 1 Then
                  sStatus = "销售单货物已经收到"
                  fColor = &H80000008
                 Else
                  sStatus = "草稿（没有生效）"
                  fColor = &H808080
               End If
             Else
               sStatus = "草稿（没有生效）"
               fColor = &H0&
            End If
            Grid4.Col = 1
            Grid4.CellAlignment = 1
            Grid4.CellForeColor = fColor
            Grid4.CellBackColor = bColor
            If Not IsNull(rRecord.Fields("SheetID")) Then
               Grid4.Text = rRecord.Fields("SheetID")
            End If
            Grid4.Col = 2
            Grid4.CellAlignment = 1
            Grid4.CellForeColor = fColor
            Grid4.CellBackColor = bColor
            If Not IsNull(rRecord.Fields("UnitName")) Then
               Grid4.Text = rRecord.Fields("UnitName")
            End If
            Grid4.Col = 3
            Grid4.CellAlignment = 1
            Grid4.CellForeColor = fColor
            Grid4.CellBackColor = bColor
            If Not IsNull(rRecord.Fields("Qua")) Then
               Grid4.Text = rRecord.Fields("Qua")
            End If
            Grid4.Col = 4
            Grid4.CellAlignment = 1
            Grid4.CellForeColor = fColor
            Grid4.CellBackColor = bColor
            If Not IsNull(rRecord.Fields("Amo")) Then
               Grid4.Text = rRecord.Fields("Amo")
            End If
            Grid4.Col = 5
            Grid4.CellAlignment = 1
            Grid4.CellForeColor = fColor
            Grid4.CellBackColor = bColor
            Grid4.Text = sStatus
            Grid4.Col = 6
            Grid4.CellAlignment = 1
            Grid4.CellForeColor = fColor
            Grid4.CellBackColor = bColor
            If Not IsNull(rRecord.Fields("Date")) Then
               Grid4.Text = rRecord.Fields("Date")
            End If
            rRecord.MoveNext
            hh = hh + 1
         Loop
      End If
       
    rRecord.Close
    Con.Close
    Set rRecord = Nothing
    Set Con = Nothing
    Grid4.Row = 1
    Grid4.Col = 1
  End If
    Grid4.ColSel = 6
    Grid4.Visible = True
    
   Exit Sub
Err_S:
  MsgBox "很抱歉，不能正常配置网格（或查询供应商） " & vbCrLf & vbCrLf & "：