frmoption1.frm

餐饮茶馆管理系统

  End If
  
  If Val(txtCompanyLen) < 2 Then
     txtCompanyLen = 8
  End If
  
  SaveSetting App.EXEName, "Option", "Company", txtCompany
  SaveSetting App.EXEName, "Option", "CompanyLen", txtCompanyLen
  
  sCompany = txtCompany
  lCompany = Val(txtCompanyLen)
  
  Unload Me
  
End Sub

Private Sub cmdSelectType_Click()

   Load frmSelectType
   frmSelectType.Left = frmOption1.cmdSelectType.Left + frmOption1.Left + frmOption1.cmdSelectType.Width
   frmSelectType.Top = frmOption1.cmdSelectType.Top + frmOption1.Top + frmOption1.cmdSelectType.Height + 750

   frmSelectType.Show 1
   
   If sType <> "" Then
      cmbType.Text = sType
      If cmdAdd.Enabled = True Then cmdAdd.SetFocus
   End If

End Sub

Private Sub cmdSelectUnit_Click()

   Load frmSelectUnit
   frmSelectUnit.Left = frmOption1.cmdSelectUnit.Left + frmOption1.Left + frmOption1.cmdSelectUnit.Width
   frmSelectUnit.Top = frmOption1.cmdSelectUnit.Top + frmOption1.Top + frmOption1.cmdSelectUnit.Height + 750

   frmSelectUnit.Show 1
   
   If sUnit <> "" Then
      txtDW.Text = sUnit
      txtCode.SetFocus
   End If
   
End Sub

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

 If pic2.Visible = True Then
    If KeyCode = 46 Then 'Del
      If Shift = 1 Then
         DelRecord Grid1.Text, "名称", "EatList"
       ' 刷新数据
         Grid1.RemoveItem Grid1.Row
      Else
       cmdDel.Value = True
      End If
    End If
    Exit Sub
 End If
 If pic3.Visible = True Then
    If KeyCode = 46 Then 'Del
       cmdDelLine.Value = True
    End If
    Exit Sub
 End If
  
End Sub

Private Sub Form_Load()
  
  FO = True
  On Error GoTo Err_Load
  Dim L As Long, T As Long
  L = Val(GetSetting(App.EXEName, "Option", "Option_L", 2000))
  T = Val(GetSetting(App.EXEName, "Option", "Option_T", 2000))
  Me.Left = L
  Me.Top = T

    Screen.MousePointer = 11
  ' 配置网格
    ConfigGrid
  
  ' 配置名称
    txtCompany = sCompany
    txtCompanyLen = lCompany
    
   Screen.MousePointer = 0
  Exit Sub
Err_Load:
 MsgBox "表单加载错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Sub Form_Unload(Cancel As Integer)

 FO = False
 SaveSetting App.EXEName, "Option", "Option_L", Me.Left
 SaveSetting App.EXEName, "Option", "Option_T", Me.Top
 
End Sub

Private Sub txtAddLine_Change()

 If txtAddLine <> "" Then
    cmdAddLine.Enabled = True
  Else
    cmdAddLine.Enabled = False
 End If
 
End Sub

Private Sub txtAddLine_KeyPress(KeyAscii As Integer)

 If KeyAscii = 13 Then
    If cmdAddLine.Enabled = True Then cmdAddLine.Value = True
 End If
 
End Sub

Private Sub Picture1_Click()

End Sub

Private Sub txtCode_Change()

 If txtPM <> "" And txtDJ <> "" And txtCode <> "" Then
     cmdAdd.Enabled = True
    Else
     cmdAdd.Enabled = False
  End If
  
End Sub

Private Sub txtCode_GotFocus()
  
  txtCode.SelStart = 0
  txtCode.SelLength = Len(txtCode)
  
End Sub

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

  DirectFocus txtDW, cmbType, txtCode, txtCode, KeyCode
  
End Sub

Private Sub txtCompany_GotFocus()

  txtCompany.SelStart = 0
  txtCompany.SelLength = Len(txtCompany)
  
End Sub

Private Sub txtCompany_KeyPress(KeyAscii As Integer)

End Sub

Private Sub txtCompanyLen_GotFocus()

  txtCompanyLen.SelStart = 0
  txtCompanyLen.SelLength = Len(txtCompany)
  
End Sub

Private Sub txtCompanyLen_KeyPress(KeyAscii As Integer)

If (KeyAscii > 46 And KeyAscii < 58 And KeyAscii <> 47) Or KeyAscii = 8 Then
    Exit Sub
 Else
   KeyAscii = 0
End If

End Sub

Private Sub txtDJ_Change()

If txtPM <> "" And txtDJ <> "" And txtCode <> "" Then
     cmdAdd.Enabled = True
    Else
     cmdAdd.Enabled = False
  End If
  
End Sub

Private Sub txtDJ_GotFocus()

  txtDJ.SelStart = 0
  txtDJ.SelLength = Len(txtDJ)
  
End Sub

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

DirectFocus txtPM, txtDW, txtDJ, txtDJ, KeyCode

End Sub

Private Sub txtDJ_KeyPress(KeyAscii As Integer)

If (KeyAscii > 45 And KeyAscii < 58 And KeyAscii <> 47) Or KeyAscii = 8 Then
   If KeyAscii = 46 And InStr(1, txtDJ, ".", vbBinaryCompare) > 0 Then '为小数点时
      KeyAscii = 0
   End If
      Exit Sub
   Else
   KeyAscii = 0
End If

End Sub

Private Sub txtDW_GotFocus()
  
  txtDW.SelStart = 0
  txtDW.SelLength = Len(txtDW)
  
End Sub

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

 DirectFocus txtDJ, txtCode, txtDW, txtDW, KeyCode

End Sub

Private Sub txtDW_KeyPress(KeyAscii As Integer)

 If KeyAscii = 13 And Trim(txtDW) <> "" Then
    KeyAscii = 0
    txtCode.SetFocus
  Else
    KeyAscii = 0
    cmdSelectUnit.Value = True
 End If
 
End Sub

Private Sub txtJE_Change()

 If txtJE = "" Then
   txtJE = "0"
   txtJE.SelStart = 0
   txtJE.SelLength = Len(txtJE)
 End If
 
End Sub

Private Sub txtJE_GotFocus()

 txtJE.SelStart = 0
 txtJE.SelLength = Len(txtJE)
 
End Sub

Private Sub txtJE_KeyPress(KeyAscii As Integer)

If (KeyAscii > 45 And KeyAscii < 58 And KeyAscii <> 47) Or KeyAscii = 8 Then
   If KeyAscii = 46 And InStr(1, txtJE, ".", vbBinaryCompare) > 0 Then '为小数点时
      KeyAscii = 0
   End If
      Exit Sub
 Else
   KeyAscii = 0
End If

End Sub

Private Sub txtJE_LostFocus()

 If txtJE = "0" Then
    txtJE = "4.0"
 End If
 
End Sub

Private Sub txtJS_Change()

 If txtJS = "" Then
   txtJS = "0"
   txtJS.SelStart = 0
   txtJS.SelLength = Len(txtJS)
 End If
 
End Sub

Private Sub txtJS_GotFocus()

 txtJS.SelStart = 0
 txtJS.SelLength = Len(txtJS)
 
End Sub

Private Sub txtJS_KeyPress(KeyAscii As Integer)

If (KeyAscii > 47 And KeyAscii < 58) Or KeyAscii = 8 Then
   Exit Sub
 Else
   KeyAscii = 0
End If

End Sub

Private Sub txtJS_LostFocus()

 If txtJS = "0" Then
    txtJS = "15"
 End If
 
End Sub

Private Sub txtPM_Change()

  If txtPM <> "" And txtDJ <> "" And txtCode <> "" Then
     cmdAdd.Enabled = True
    Else
     cmdAdd.Enabled = False
  End If
  
End Sub

Private Sub txtPM_GotFocus()

  txtPM.SelStart = 0
  txtPM.SelLength = Len(txtPM)
  
End Sub

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

 DirectFocus txtPM, txtDJ, txtPM, txtPM, KeyCode

End Sub


Private Sub ConfigGrid()

On Error GoTo Err_init
Grid1.Visible = False
Grid1.Clear
Grid1.Cols = 6
Grid1.FormatString = "^ .. |^ 物品名称 |^ 单价 |^ 单位 |^ 代码 |^ 类别 "
Grid1.ColWidth(0) = 300
Grid1.ColWidth(1) = 1800
Grid1.ColWidth(2) = 600
Grid1.ColWidth(3) = 800
Grid1.ColWidth(4) = 1000
Grid1.ColWidth(5) = 1030

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 DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
    
    Set EF = DB.OpenRecordset("EatList", dbOpenTable)
        DelNO = EF.RecordCount
        Grid1.Rows = EF.RecordCount + 1
    Set EF = DB.OpenRecordset("EatList", dbOpenDynaset)
        HH = 1
        Do While Not EF.EOF()
           Grid1.Row = HH
           Grid1.Col = 0
           Grid1.CellAlignment = 4
        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
        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
        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
        If Not IsNull(EF.Fields(2).Value) Then
           Grid1.Text = EF.Fields(2).Value
        End If
           Grid1.Row = HH
           Grid1.Col = 4
           Grid1.CellAlignment = 1
        If Not IsNull(EF.Fields(4).Value) Then
           Grid1.Text = EF.Fields(4).Value
        End If
           Grid1.Row = HH
           Grid1.Col = 5
           Grid1.CellAlignment = 1
        If Not IsNull(EF.Fields(5).Value) Then
           Grid1.Text = EF.Fields(5).Value
        End If
        
          EF.MoveNext
          HH = HH + 1
        Loop
        EF.Close
        DB.Close
 Grid1.Col = 1
 Grid1.Row = 1
 Grid1.ColSel = 5
 Grid1.Visible = True
   Exit Sub
Err_init:
 MsgBox "网络配置错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Sub DelRecord(sWP As String, sFields As String, sTable As String)

   On Error GoTo Err_init
   Dim DB As Database
   Dim sEXE As String
   
   Set DB = OpenDatabase(ConData, False, False, Constr)
   'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
   
   ' SQL语言删除
     sEXE = "Delete * From " & sTable & " Where " & sFields & "='" & sWP & "'"
     DBEngine.BeginTrans     ' 进行事务操作
     DB.Execute sEXE
     DBEngine.CommitTrans
     DB.Close
          Exit Sub
Err_init:
 MsgBox "记录删除错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Sub AddRecord(sWP1 As String, sFields1 As String, sWP2 As Currency, sFields2 As String, sWP3 As String, sFields3 As String, sWP4 As String, sFields4 As String, sWP5 As String, sFields5 As String, sTable As String)

  On Error GoTo Err_init
   Dim DB As Database
   Dim sEXE As String
   
   Set DB = OpenDatabase(ConData, False, False, Constr)
   'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
   
   ' SQL语言删除
     sEXE = "Insert into " & sTable & " (" & sFields1 & "," & sFields2 & "," & sFields3 & "," & sFields4 & "," & sFields5 & ") values('" & sWP1 & "'," & sWP2 & ",'" & sWP3 & "','" & sWP4 & "','" & sWP5 & "')"
     DBEngine.BeginTrans     ' 进行事务操作
     DB.Execute sEXE
     DBEngine.CommitTrans
     DB.Close
          Exit Sub
Err_init:
 MsgBox "添加记录错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Function GetCode(sWP As String, sFields As String, sTable As String) As Boolean

  On Error GoTo Err_init
   Dim DB As Database
   Dim EF As Recordset
   Dim sEXE As String
   
   Set DB = OpenDatabase(ConData, False, False, Constr)
   'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
   
   ' SQL语言删除
     sEXE = "Select * From " & sTable & " Where " & sFields & "='" & sWP & "'"
   Set EF = DB.OpenRecordset(sEXE, dbOpenDynaset)
     If EF.EOF And EF.BOF Then
        GetCode = True
      Else
        GetCode = False
     End If
     EF.Close
     DB.Close
     Exit Function
     
Err_init:
 MsgBox "添加记录错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 GetCode = False
 
End Function