frmdetailform.frm

星级酒店管理系统（附带系统自写控件源码）

  Call MoveToNext(KeyCode)
  
End Sub

Private Sub cmbStore_KeyPress(KeyAscii As Integer)

 If KeyAscii = 13 Then
    SendKeys "{tab}"
 End If
 
End Sub

Private Sub cmbStore_LostFocus()

  If cmbStore.Text = "" Then Exit Sub
  
  If LostControl("StoreType", "StoreName", cmbStore.Text) = False Then
     MsgBox "[ " + cmbStore.Text + " ] 为没有定义的仓库名称,请重新输入。    ", vbInformation, "请在基础设置中先定义仓库名称"
     cmbStore.Text = ""
     cmbStore.SetFocus
  End If
  
End Sub

Private Sub cmbPayMethod_Change()
  
  Call Valid_OK
  If cmdOK.Enabled = True Then
     cmdOK.SetFocus
  End If
  
End Sub

Private Sub cmbPaymethod_Click()

  On Error Resume Next
  Call Valid_OK
  If cmdOK.Enabled = True Then
     cmdOK.SetFocus
  End If
  
End Sub

Private Sub cmbStyle_Change()

  Call Valid_OK
  
End Sub

Private Sub cmbStyle_Click()

  Call Valid_OK
  cmdOK.SetFocus
  
End Sub

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

  Call MoveToNext(KeyCode)
  
End Sub

Private Sub cmbStyle_KeyPress(KeyAscii As Integer)

 If KeyAscii = 13 Then
    SendKeys "{tab}"
 End If
 
End Sub

Private Sub cmbStyle_LostFocus()

  If cmbStyle.Text = "" Then Exit Sub
  
  If Val(cmbStyle.Text) >= 0 And Val(cmbStyle.Text) <= 23 Then
     Exit Sub
   Else
     MsgBox "[ " + cmbStyle.Text + " ] 为无效的时间,请重新输入。    " & vbCrLf & vbCrLf & "    正确的时间是0-23之间的数字。   ", vbInformation, "请先定义类别名"
     cmbStyle.Text = ""
     cmbStyle.SetFocus
  End If

End Sub

Private Sub cmdClose_Click()

  frmDetail.bSearch = False
  Unload Me
  
End Sub

Private Sub cmdOK_Click()

  On Error Resume Next
  
  SCondStr = ""
  
  Dim TmpStr As String
      TmpStr = ""
  If Trim(cmbCode.Text) <> "" Then
     If chkFull.Value = vbChecked Then
        TmpStr = TmpStr & " And (CID='" & Trim(cmbCode.Text) & "')"
       Else
        TmpStr = TmpStr & " And (CID Like '" & Trim(cmbCode.Text) & "*')"
     End If
  End If
  If Trim(txtName.Text) <> "" Then
     If chkFull.Value = vbChecked Then
        TmpStr = TmpStr & " And (Name='" & Trim(txtName.Text) & "')"
      Else
        TmpStr = TmpStr & " And (Name Like '" & Trim(txtName.Text) & "*')"
     End If
  End If
  If Trim(txtPingyin.Text) <> "" Then
     If chkFull.Value = vbChecked Then
        TmpStr = TmpStr & " And (Pingyin='" & Trim(txtPingyin.Text) & "')"
       Else
        TmpStr = TmpStr & " And (Pingyin Like '" & Trim(txtPingyin.Text) & "*')"
     End If
  End If
  If Trim(txtType.Text) <> "" Then
     If chkFull.Value = vbChecked Then
        TmpStr = TmpStr & " And (DType='" & Trim(txtType.Text) & "')"
       Else
        TmpStr = TmpStr & " And (DType Like '" & Trim(txtType.Text) & "')"
     End If
  End If
  
  If Left(TmpStr, 4) = " And" Then
     TmpStr = Right(TmpStr, Len(TmpStr) - 4)
  End If
  
  If Trim(TmpStr) = "" Then
     SCondStr = " Where (Date>=#" & dtStart.Value & "# And Date<=#" & dtEnd.Value & "#)"
     Else
     SCondStr = " Where (Date>=#" & dtStart.Value & "# And Date<=#" & dtEnd.Value & "#) And " & TmpStr
  End If
   
  frmDetail.bSearch = True
  '御载
  Unload Me
  
End Sub

Private Sub cmdSelectDate_Click()

 On Error Resume Next
 
 'Me.MousePointer = 11
 '  Calendar.Show 1
 'Me.MousePointer = 0
 
 '代入选择的值
 If Trim(DateStr) = "" Then
    txtSellDate.SetFocus
    Exit Sub
 End If
 
 txtSellDate = DateStr
 If txtSellDateE.Text <> "____-__-__" Then
    chkEndDate.Visible = False
    Label1(5).Visible = True
    txtSellDateE.Visible = True
    cmdSelectDateE.Visible = True
    Label1(5).Enabled = True
    txtSellDateE.Enabled = True
    cmdSelectDateE.Enabled = True
    cmbBranchName.SetFocus
  Else
    chkEndDate.SetFocus
 End If
 
End Sub

Private Sub cmdSelectDateE_Click()

 On Error Resume Next
 
 Me.MousePointer = 11
  ' Calendar.Show 1
 Me.MousePointer = 0
 
 '代入选择的值
 If Trim(DateStr) = "" Then
    txtSellDateE.SetFocus
    Exit Sub
 End If
 
 txtSellDateE = DateStr
 If cmbBranchName.Enabled = True Then
    cmbBranchName.SetFocus
 End If

End Sub

Private Sub Form_Load()
   
  On Error GoTo LoadErr
  '装载数据
  frmDetail.bSearch = False
  SCondStr = ""
  GetFormSet Me, Screen
  dtStart.Value = CDate(GetSetting(App.EXEName, "Option", "StartDate", Date))
  dtEnd.Value = CDate(GetSetting(App.EXEName, "Option", "EndDate", Date))
  cmbStart.ListIndex = CInt(GetSetting(App.EXEName, "Option", "StartTime", 0))
  cmbEnd.ListIndex = CInt(GetSetting(App.EXEName, "Option", "EndTime", 0))
    
  Exit Sub
LoadErr:
  MsgBox "装载错误：" & Err.Description, vbCritical
  Exit Sub
  
End Sub

Private Sub LoadData()

  Dim DB As Database, Ef As Recordset
  Dim TmpStr As String
  
  On Error Resume Next
  
  Set DB = OpenDatabase(ConData, False, False, Constr)

  '检查座位分类
  Set Ef = DB.OpenRecordset("SiteType", dbOpenDynaset)
      If Ef.EOF And Ef.BOF Then
         cmbStyle.Enabled = False
        Else
         Do Until Ef.EOF()
            If Not IsNull(Ef.Fields("Class").Value) Then
               TmpStr = Ef.Fields("Class").Value
               txtProductName.AddItem TmpStr
            End If
            Ef.MoveNext
         Loop
      End If
  Ef.Close
  DB.Close

End Sub

Private Sub dtEnd_Change()

  On Error Resume Next
  If dtEnd.Value < dtStart.Value Then
     dtStart.Value = dtEnd.Value
  End If
  
End Sub

Private Sub dtStart_Change()

  On Error Resume Next
  If dtStart.Value > dtEnd.Value Then
     dtEnd.Value = dtStart.Value
  End If
  
End Sub

Private Sub txtProductName_Change()

  Call Valid_OK
  
End Sub

Private Sub txtProductName_Click()

  cmdOK.SetFocus
  
End Sub

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

  Call MoveToNext(KeyCode)
  
End Sub

Private Sub txtProductName_KeyPress(KeyAscii As Integer)

 If KeyAscii = 13 Then
    SendKeys "{tab}"
 End If
 
End Sub

Private Sub txtProductName_LostFocus()

  If txtProductName.Text = "" Then Exit Sub
  
  If LostControl("SiteType", "Class", txtProductName.Text) = False Then
     MsgBox "[ " + txtProductName.Text + " ] 为没有定义的座位号,请重新输入。    ", vbInformation, "请在基础设置中先定义座位号"
     txtProductName.Text = ""
     txtProductName.SetFocus
  End If

End Sub

Private Sub txtSellDate_Change()

  Call Valid_OK
      
  On Error Resume Next
  If TestDate(txtSellDate.Text) Then
     chkEndDate.Enabled = True
      If txtSellDateE.Text <> "____-__-__" Then
         chkEndDate.Visible = False
         Label1(5).Visible = True
         txtSellDateE.Visible = True
         cmdSelectDateE.Visible = True
         Label1(5).Enabled = True
         txtSellDateE.Enabled = True
         cmdSelectDateE.Enabled = True
         cmbBranchName.SetFocus
         Exit Sub
      End If
     chkEndDate.SetFocus
    Else
     chkEndDate.Enabled = False
     Label1(5).Visible = False
     txtSellDateE.Visible = False
     cmdSelectDateE.Visible = False
     Label1(5).Enabled = False
     txtSellDateE.Enabled = False
     cmdSelectDateE.Enabled = False
  End If
 
End Sub

Private Function LostControl(SRecordset As String, SField As String, sValue As String) As Boolean

   Dim DB As Database, Ef As Recordset, TmpStr As String
       TmpStr = "Select * From " & SRecordset & " Where " & SField & "='" & sValue & "'"
       
       On Error Resume Next

  Set DB = OpenDatabase(ConData, False, False, Constr)
       Set Ef = DB.OpenRecordset(TmpStr, dbOpenDynaset)
           
         If Ef.EOF And Ef.BOF Then
            LostControl = False
         Else
            LostControl = True
         End If
         
       Ef.Close
       DB.Close
   
End Function

Private Sub Valid_OK()
   
   If txtSellDate.Text <> "____-__-__" Or cmbBranchName.Text <> "" Or txtProductName.Text <> "" _
      Or txtNO <> "" Or cmbStyle.Text <> "" Or cmbPayMethod.Text <> "" Then
      cmdOK.Enabled = True
   Else
      cmdOK.Enabled = False
   End If
   
End Sub

Private Sub GoFocus(CGF As Control)

   CGF.SelStart = 0
   CGF.SelLength = Len(CGF.Text)
   
End Sub

Private Sub MoveToNext(KS As Integer)
 
 If KS = 39 Then
    SendKeys "{tab}"
 End If
 
End Sub

Private Sub txtSellDateE_Change()

  Call Valid_OK
  
  If TestDate(txtSellDateE.Text) Then
     If cmbBranchName.Enabled = True Then
        cmbBranchName.SetFocus
     End If
  End If

End Sub

Private Function TestDate(strDate As String) As Boolean

  If IsDate(strDate) = True Then
     TestDate = True
    Else
     TestDate = False
  End If
  
End Function

Private Sub ConfigPayMethod()

  Dim DB As Database, Ef As Recordset, HH As Integer
  Set DB = OpenDatabase(ConData, False, False, Constr)
           
    Set Ef = DB.OpenRecordset("Select * From PayType", dbOpenDynaset)
        HH = 1
        Do While Not Ef.EOF()
          If Not IsNull(Ef.Fields(1)) Then
             cmbPayMethod.AddItem Ef.Fields(1).Value
          End If
          Ef.MoveNext
          HH = HH + 1
        Loop
        
  Ef.Close
  DB.Close
  
  If HH > 1 Then
     cmbPayMethod.ListIndex = GetSetting(App.EXEName, "Option", "PayMethod", 0)
     SaveSetting App.EXEName, "Option", "PayMethod", cmbPayMethod.ListIndex
  End If
 
End Sub