frmorder.frm

本程序源码是由vb编写的

Private Sub picTool1_Resize()

   On Error Resume Next
   cmdReturn.left = picTool1.Width - cmdReturn.Width - 200

End Sub

Private Sub Picture1_Resize()
  
   On Error Resume Next
   Command3.left = Picture1.Width - Command3.Width - 200

End Sub

Private Sub tbOrder_ButtonClick(ByVal Button As MSComctlLib.Button)

 Select Case Button.Key
 
   Case "new"
     FormID = "Order100"
     If txtUnitID.Enabled = True And txtEdit.Enabled = True Then
        SaveRecord False
     End If
     CreateOrder
     txtUnitID.SetFocus
   Case "del"  'Delete
        DelDialog.Show 1
     If bDelSelect = 1 Then
        If Trim(Grid1.TextMatrix(Grid1.Row, 1)) = "" Then Exit Sub
        Grid1.RemoveItem Grid1.Row
        Grid1.AddItem bb
        'Refresh Acount
        AcountThis
        txtEdit.Text = Grid1.Text
        Grid1.Row = 1
        Grid1.Col = 1
        Grid1.ColSel = 1
      ElseIf bDelSelect = 2 Then
        'Delete Sheet
         If lbSheetID.Caption = "" Then Exit Sub
         DelRecord lbSheetID.Caption
         MaskAll True
     End If
   Case "browser"
     FormID = "Order200"
     OrderBrowser
   Case "check"
     SaveRecord True
   Case "return"
     If picSelectP.left >= 0 Then
        FormID = "Order100"
        MovePic picSelectP, False, frmOrder, txtEdit, Grid3
        Exit Sub
     End If
     If picSelectSuppler.left >= 0 Then
        FormID = "Order100"
        MovePic picSelectSuppler, False, frmOrder, txtUnitID, Grid2
        Exit Sub
     End If
     If picBrowser.left >= 0 Then
        FormID = "Order100"
           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, frmOrder, Grid1, Grid4
        Exit Sub
     End If
     If txtUnitID.Enabled = True And txtEdit.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 "Order100"
                Start_print.N_TiTle = "订单"
                Start_print.N_Head10 = "单位：" & lbUnit
                Start_print.N_Head11 = "制单人：" & sUserName
                Start_print.N_Head2 = "时间：" & dpDate.Value
                Set Start_print.N_Grid = Grid1
          Case "Order200"
                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
          Case "GS100"
                Start_print.N_TiTle = "供应商报表"
                Start_print.N_Head10 = "制单人：" & sUserName
                Start_print.N_Head11 = ""
                Start_print.N_Head2 = "时间：" & Format(Now, "Long Date")
                Set Start_print.N_Grid = Grid2
          Case "PD100"
                Start_print.N_TiTle = "产品报表"
                Start_print.N_Head10 = "制单人：" & sUserName
                Start_print.N_Head11 = ""
                Start_print.N_Head2 = "时间：" & Format(Now, "Long Date")
                Set Start_print.N_Grid = Grid3
        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
   ConfigProduct "Select * From ProductType", True
   ConfigOrder "Select * From OrderSheet"
   
  '装载动画光标
   New_AniCur1.AniFileName = App.Path + "\sys\9.ani"
   New_AniCur1.SetAniCursor Grid2.hwnd
   
   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 txtEdit_DblClick()

  If Grid1.Col = 1 Then
     Call cmdSelect_Click
  End If
  
End Sub

Private Sub txtEdit_KeyDown(KeyCode As Integer, Shift As Integer)
 
  If Grid1.Col = 1 Then Exit Sub
     Reserved KeyCode
  
End Sub

Private Sub txtEdit_KeyPress(KeyAscii As Integer)

  If Grid1.Row = 0 Or Grid1.Col = 0 Then Exit Sub
  If Grid1.Col = 3 And Grid1.TextMatrix(Grid1.Row, 1) = "" Then
     KeyAscii = 0
     Exit Sub
  End If
  If Grid1.Col > 3 And Grid1.Col < 7 + CodeQua Then
    If Trim(Grid1.TextMatrix(Grid1.Row, 1)) = "" Then
        KeyAscii = 0
        MsgBox "很抱歉，请先输入产品编号之后才能输入！    ", vbInformation
        Exit Sub
    End If
   ElseIf Grid1.Col = 1 And KeyAscii = 13 Then
     If Trim(txtEdit.Text) = "" Then Exit Sub
       'Search UnitID
        ProductSearch Trim(txtEdit.Text), "Goods"
     If GetProduct.Exsite = False Then
        'Clear Data
         txtEdit.Text = Grid1.Text
         txtEdit.SetFocus
        Exit Sub
      ElseIf Grid1.TextMatrix(Grid1.Row, 4) = "" And Grid1.TextMatrix(Grid1.Row, 5) = "" Then
            Grid1.TextMatrix(Grid1.Row, 1) = GetProduct.ID
            Grid1.TextMatrix(Grid1.Row, 2) = GetProduct.Name
            Grid1.TextMatrix(Grid1.Row, 3) = GetProduct.Unit
            For x = 1 To CodeQua
                Grid1.TextMatrix(Grid1.Row, 3 + x) = 0
            Next
            Grid1.TextMatrix(Grid1.Row, 4 + CodeQua) = GetProduct.Price
            Grid1.TextMatrix(Grid1.Row, 5 + CodeQua) = 0
            Grid1.Col = 4   'Return price cell
            Grid1.RowSel = Grid1.Row
            Grid1.ColSel = 4
        Else
        If Trim(Grid1.Text) <> Trim(txtEdit.Text) Then   'Same recorde
            Grid1.TextMatrix(Grid1.Row, 1) = GetProduct.ID
            Grid1.TextMatrix(Grid1.Row, 2) = GetProduct.Name
            Grid1.TextMatrix(Grid1.Row, 3) = GetProduct.Unit
            For x = 1 To CodeQua
                Grid1.TextMatrix(Grid1.Row, 3 + x) = 0
            Next
            Grid1.TextMatrix(Grid1.Row, 4 + CodeQua) = GetProduct.Price
            Grid1.TextMatrix(Grid1.Row, 5 + CodeQua) = 0
        End If
        Grid1.Col = 4   'Return price cell
        Grid1.RowSel = Grid1.Row
        Grid1.ColSel = 4
     End If
  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 = 7
   Grid2.FormatString = "..|^ 编号 |^ 供应商名称 |^ 联系人 |^ 电话 |^ 传真 |^地址"
   Grid2.ColWidth(0) = 200
   Grid2.ColWidth(1) = 1000
   Grid2.ColWidth(2) = 3500
   Grid2.ColWidth(3) = 1200
   Grid2.ColWidth(4) = 2000
   Grid2.ColWidth(5) = 4000
   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
         Grid2.BackColorSel = SelectBackColor
         Grid2.ForeColorSel = SelectForeColor
         Grid2.Rows = GridNO + 5
         If Grid2.Rows < 34 Then  '缺省的30行
            Grid2.Rows = 34
         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
            Grid