frmfk.frm

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

   Case "del"  'Delete
        Load DelDialog
        DelDialog.optSelectItem(1).Value = True
        DelDialog.optSelectItem(0).Enabled = False
        DelDialog.Show 1
     If bDelSelect = 1 Then
        Exit Sub
       ElseIf bDelSelect = 2 Then
        'Delete Sheet
         If lbSheetID.Caption = "" Then Exit Sub
         DelRecord lbSheetID.Caption
         MaskAll True
     End If
   Case "browser"
     OrderBrowser
   Case "check"
     If Trim(txtFK.Text) = "" Then txtFK.Text = 0
        SaveRecord True
   Case "return"
     If picSelectSuppler.left >= 0 Then
        MovePic picSelectSuppler, False, Me, txtUnitID, Grid2
        Exit Sub
     End If
     If picBrowser.left >= 0 Then
           tbOrder.Buttons(1).Enabled = True
        If txtUnitID.Enabled = True Then
           tbOrder.Buttons(6).Enabled = True
           tbOrder.Buttons(8).Enabled = True
           tbOrder.Buttons(2).Enabled = True
           Else
           tbOrder.Buttons(6).Enabled = False
        End If
           tbOrder.Buttons(4).Enabled = True
           MovePic picBrowser, False, Me, txtUnitID, Grid4
        Exit Sub
     End If
     If txtUnitID.Enabled = True Then
        SaveRecord False
     End If
     Unload Me
 End Select
 
End Sub

Private Sub tbOrder_ButtonMenuClick(ByVal ButtonMenu As MSComctlLib.ButtonMenu)

          '打印时给表头三部分+表名+行高++++++++++++++++++++++++++++++++++++++++++++++++++
             'On Error GoTo Print_Err
        Select Case FormID
          Case "FK200"
                Start_print.N_TiTle = "付款明细表"
                Start_print.N_Head10 = "制单人：" & sUserName
                Start_print.N_Head11 = ""
                Start_print.N_Head2 = "时间：" & dtStartDate.Value & "到" & dtEndDate.Value
                Set Start_print.N_Grid = Grid4
        End Select
         Select Case ButtonMenu.Key
           Case "set"
                  '如果值改变，将保存新的记录
                  SavePrintSet Start_print, "Get", FormID '给出该ID配置
                  frmPrintSet.Show 1
                   If PrintSetChange = True Then
                      SavePrintSet Start_print, "Save", FormID
                   End If
           Case "print"
                 Start_print.PrintPage
         End Select
         
           '释放内存
          '打印结束++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
          Exit Sub
Print_Err:
          MsgBox "对不起，打印设置或打印错误，请与供应商联系！    " & vbCrLf & vbCrLf & " 电话：[phone] 8269007 [e-mail]   ", vbInformation
          Exit Sub
End Sub

Private Sub StartLoad()

   On Error Resume Next
   bDelSelect = 0
   lbOperator = sUserName
   dpDate.Value = Date
   ConfigSuppler "Select  * From SupplerType", True
   
  '装载动画光标
   New_AniCur1.AniFileName = App.Path + "\sys\9.ani"
   
   dtEndDate.Value = Date
   dtStartDate.Value = DateAdd("d", -7, dtEndDate.Value)
   
   If dtStartDate.Value > dtEndDate Then
      dtEndDate.Value = dtStartDate.Value
   End If
   If dtEndDate.Value < dtStartDate.Value Then
      dtStartDate.Value = dtEndDate.Value
   End If
   
End Sub

Private Sub ConfigData()

   On Error GoTo Err_S
   txtEdit.Text = ""
  '配置网格
   Grid1.Clear
   Grid1.Visible = False
   Grid1.Rows = 19
   Dim sFormat As String
   Dim x As Integer
   For x = 1 To CodeQua
       sFormat = sFormat & "|<" & CodeName(x)
   Next
   Grid1.FormatString = "^ |<产品编号|<产品名称|<单位" & sFormat & "|<单价 |<总额   "
   Grid1.ColWidth(0) = 200
   Grid1.ColWidth(1) = 2300
   Grid1.ColWidth(2) = 2660
   Grid1.ColWidth(3) = 1000
   'Code Qua starting ...
   For x = 1 To CodeQua
       Grid1.ColWidth(x + 3) = 800
   Next
   Grid1.ColWidth(4 + CodeQua) = 1200
   Grid1.ColWidth(5 + CodeQua) = 1750

    Grid1.Col = 0
    Grid1.Row = 1
    Grid1.Col = 1
    Grid1.ColSel = 1
    Grid1.Visible = True
    txtEdit = ""
    txtEdit.left = (Grid1.left + Grid1.CellLeft) - 10
    txtEdit.tOp = Grid1.tOp + Grid1.CellTop - 10
    txtEdit.Width = Grid1.CellWidth + 20
    cmdSelect.tOp = Grid1.tOp + Grid1.CellTop + 8
    cmdSelect.left = txtEdit.left + (txtEdit.Width - cmdSelect.Width) - 30
        
   Exit Sub
Err_S:
  MsgBox "很抱歉，不能正常配置网格：请到WWW.VB-CODE.NET网站咨询   " & vbCrLf & vbCrLf & Err.Description, vbInformation, "Error for form load."
  Exit Sub

End Sub

Private Sub TimeDate_Timer()

   lbDate.Caption = Format(Time, "hh:mm:ss AM/PM")
   
End Sub

Private Sub txtFK_Change()

  If Trim(txtFK.Text) = "" Then
     txtFK.Text = 0
  End If
  
End Sub

Private Sub txtSupplerName_KeyPress(KeyAscii As Integer)

 If txtSupplerName.Text <> "" And KeyAscii = 13 Then
    Call cmdSearchOrder_Click
 End If
 
End Sub

Private Sub txtUnitID_DblClick()
 
  Call cmdSelectGuest_Click
 
End Sub

Private Sub txtUnitID_GotFocus()

  '保留原来数据
   UnitID_old = Trim(txtUnitID.Text)
   
End Sub

Private Sub txtUnitID_KeyPress(KeyAscii As Integer)

   'Return Key
   If KeyAscii = 13 Then
      Call cmdSelectGuest_Click
   End If
   
End Sub

Private Sub txtUnitID_LostFocus()

  '离开时确定该编号是否存在
   'If Trim(txtUnitID.Text) = "" Then Exit Sub
   
   Dim sUnitName As String
      sUnitName = GetUnitName(Trim(txtUnitID), "Suppler")
   If sUnitName = "" Then
      txtUnitID.Text = UnitID_old
      'MsgBox "对不起， 该供应商不存在。    ", vbInformation
      Exit Sub
     Else
      lbUnit.Caption = sUnitName
   End If
   
End Sub

Private Sub ConfigSuppler(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 = New Recordset
 '     rRecord.Open sSql, Con, adOpenStatic, adLockPessimistic, adCmdText
  Dim Con As Database
  Dim rRecord As Recordset
  Set Con = OpenDatabase(ConData, 0, 0, ConStr)
  Set rRecord = Con.OpenRecordset(sSQL, dbOpenDynaset)
    
  If bContent = False Then
     GuestLay = 2
  '配置网格
   Grid2.Visible = False
   Grid2.Clear
   Grid2.Cols = 6
   Grid2.FormatString = "..|^ 编号 |^ 供应商名称 |^ 联系人 |^ 电话 |^ 欠款金额"
   Grid2.ColWidth(0) = 200
   Grid2.ColWidth(1) = 1000
   Grid2.ColWidth(2) = 4500
   Grid2.ColWidth(3) = 1200
   Grid2.ColWidth(4) = 2660
   Grid2.ColWidth(5) = 2000
   If rRecord.BOF Or rRecord.EOF Then
      Grid2.Rows = 32
      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
         Grid2.BackColorSel = SelectBackColor
         Grid2.ForeColorSel = SelectForeColor
         Grid2.Rows = GridNO + 5
         If Grid2.Rows < 32 Then  '缺省的30行
            Grid2.Rows = 32
         End If
      If rRecord.BOF And rRecord.EOF Then
         Else
         rRecord.MoveFirst
             HH = 1
         Do While Not rRecord.EOF
            Grid2.Row = HH
            Grid2.Col = 1
            Grid2.CellAlignment = 1
            If Not IsNull(rRecord.Fields("UnitID")) Then
               Grid2.Text = rRecord.Fields("UnitID")
            End If
            Grid2.Col = 2
            Grid2.CellAlignment = 1
            If Not IsNull(rRecord.Fields("UnitName")) Then
               Grid2.Text = rRecord.Fields("UnitName")
            End If
            Grid2.Col = 3
            Grid2.CellAlignment = 1
            If Not IsNull(rRecord.Fields("UnitContact")) Then
               Grid2.Text = rRecord.Fields("UnitContact")
            End If
            Grid2.Col = 4
            Grid2.CellAlignment = 1
            If Not IsNull(rRecord.Fields("UnitTel")) Then
               Grid2.Text = rRecord.Fields("UnitTel")
            End If
            Grid2.Col = 5
            Grid2.CellAlignment = 1
            If Not IsNull(rRecord.Fields("BalAmo")) Then
               Grid2.Text = rRecord.Fields("BalAmo")
            End If
            rRecord.MoveNext
            HH = HH + 1
         Loop
      End If
       
    rRecord.Close
    Con.Close
    Set rRecord = Nothing
    Set Con = Nothing
    Grid2.Row = 1
    Grid2.Col = 1
  End If
    Grid2.ColSel = 5
    Grid2.Visible = True
 Else '配置Content网格
   GuestLay = 1
   Grid2.Visible = False
   Grid2.Clear
   Grid2.Cols = 2
   Grid2.FormatString = "..|^* * * * * * * * * *  供 应 商 分 类  * * * * * * * * * *"
   Grid2.ColWidth(0) = 200
   Grid2.ColWidth(1) = 11560

   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
         Grid2.BackColorSel = SelectBackColor
         Grid2.ForeColorSel = SelectForeColor
         Grid2.Rows = GridNO + 5
         If Grid2.Rows < 32 Then  '缺省的30行
            Grid2.Rows = 32
         End If
      If rRecord.BOF And rRecord.EOF Then
         Else
         rRecord.MoveFirst
             HH = 1
         Do While Not rRecord.EOF
            Grid2.Row = HH
            Grid2.Col = 1
            Grid2.CellAlignment = 4
            If Not IsNull(rRecord.Fields("Class")) Then
               Grid2.Text = rRecord.Fields("Class")
            End If
            rRecord.MoveNext
            HH = HH + 1
         Loop
      End If
    rRecord.Close
    Con.Close
    Set rRecord = Nothing
    Set Con = Nothing
    Grid2.Row = 1
    Grid2.Col = 1
  End If
    Grid2.ColSel = 1
    Grid2.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 txtSearch_Change()

    If Trim(txtSearch.Text) <> "" Then
       Command1.Enabled = True
     Else
       Command1.Enabled = False
    End If
     
End Sub

Private Sub txtSearch_KeyPress(KeyAscii As Integer)
   
   If KeyAscii = 13 And Trim(txtSearch) <> "" Then
     If Command1.Enabled = True Then Call Command1_Click
   End If
   
End Sub

Private Sub ProductSearch(sU As String, sTable As String)

 '该供应商、与客户是否存在
 'sTable区分供应商还是客户
  sU = Trim(sU)
  
  If sU = "" Then Exit Sub
  If InStr(1, sU, "'", vbTextCompare) Then Exit Sub
  
  Dim Con As Database
  Dim rRecord As Recordset
  Dim sSQL As String
      Set Con = OpenDatabase(ConData, 0, 0, ConStr)
      sSQL = "Select  * From " & sTable & " Where GoodsID='" & sU & "'"
      Set rRecord = Con.OpenRecordset(sSQL, dbOpenDynaset)
      'rRecord.Open sSql, Con, adOpenStatic, adLockPessimistic, adCmdText
      
   If rRecord.EOF Then
      '没有查找到时
       GetProduct.Exsite = False
       MsgBox "产品编号没有找到，请重新输入...    " & vbCrLf & vbCrLf & "如果忘记了产品编号，请按按钮选择。", vbInformation
    Else
       GetProduct.Exsite = True
       GetProduct.ID = sU
       GetProduct.Name = rRecord.Fields("GoodsName")
       GetProduct.Price = rRecord.Fields("Price")
       GetProduct.Unit = rRecord.Fields("Unit")
   End If
      rRecord.Close
      Con.Close