frmchooseguest.frm

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

         BackColor       =   &H0000C000&
         Cancel          =   -1  'True
         Caption         =   "返回(&Esc)"
         BeginProperty Font 
            Name            =   "Arial"
            Size            =   9
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   375
         Left            =   6720
         Style           =   1  'Graphical
         TabIndex        =   3
         Top             =   30
         Width           =   1185
      End
   End
   Begin VB.ListBox lstResult 
      BackColor       =   &H00E0E0E0&
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   9
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00004000&
      Height          =   4140
      IntegralHeight  =   0   'False
      Left            =   135
      Sorted          =   -1  'True
      TabIndex        =   0
      ToolTipText     =   "双击或按确定按钮返回。"
      Top             =   150
      Width           =   7950
   End
End
Attribute VB_Name = "frmchooseGuest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Const CB_FINDSTRING = &H14C
Const LB_FINDSTRING = &H18F

Dim DBG As Connection
Dim Rec As Recordset

Private Sub cmdBack_Click()

 On Error Resume Next
 Dim lPos As Integer
    
    If Right(StrPathId, 1) = "\" Then
       '是目录时
        lPos = Len(StrPathId)
        Dim sTmp As String
        Dim X As Integer
            sTmp = Left(StrPathId, lPos - 1)
            lPos = lPos - 1
        For X = 1 To lPos
            If Right(sTmp, 1) <> "\" Then
               sTmp = Left(sTmp, lPos - 1)
               lPos = lPos - 1
             Else
               '新的目录时,退出
               Exit For
             End If
        Next
        StrPathId = Trim(sTmp)
       '还原StrProID
        If Right(StrProId, 1) = "\" Then
           '是目录时
            lPos = Len(StrProId)
            sTmp = Left(StrProId, lPos - 1)
            lPos = lPos - 1
            For X = 1 To lPos
                If Right(sTmp, 1) <> "\" Then
                   sTmp = Left(sTmp, lPos - 1)
                   lPos = lPos - 1
                 Else
                   '新的目录时,退出
                   Exit For
                 End If
            Next
            StrProId = Trim(sTmp)
        End If
        
  Select Case strType
    Case "Production"
    '赋值
     strRecName = "select * from tbdproduction where fldpropath='" + StrPathId + "'"
    Case "Customer"
     strRecName = "select * from tbdGuest where DDeposit>0"
    Case Else
  End Select
    '刷新
     Call Form_Activate
  Else
   '最上一层时退出
    strValue = ""
    Me.Hide
    Exit Sub
 End If
 
End Sub

Private Sub cmdFind_Click()

  On Error GoTo FindErr
  
  Dim isError As Boolean
 '在左边的框中输入条件
  Dim sTmp As String
  Dim sQue As String
      sQue = " Where "
      isError = False
  If ftGuest(0).Text <> "" And chkQuery(0).Value = vbChecked Then
     sTmp = sTmp & sQue & " DGuest Like '%" & ftGuest(0).Text & "%' "
     sQue = " And "
     isError = True
  End If
  If ftGuest(1).Text <> "" And chkQuery(1).Value = vbChecked Then
     sTmp = sTmp & sQue & " DName Like '%" & ftGuest(1).Text & "%' "
     sQue = " And "
     isError = True
  End If
  If ftGuest(2).Text <> "" And chkQuery(2).Value = vbChecked Then
     sTmp = sTmp & sQue & " DAddress Like '%" & ftGuest(2).Text & "%' "
     sQue = " And "
     isError = True
  End If
  If ftGuest(3).Text <> "" And chkQuery(3).Value = vbChecked Then
     sTmp = sTmp & sQue & " DTel Like '%" & ftGuest(3).Text & "%' "
     sQue = " And "
     isError = True
  End If
  If ftGuest(4).Text <> "" And chkQuery(4).Value = vbChecked Then
     sTmp = sTmp & sQue & " DIcq Like '%" & ftGuest(4).Text & "%' "
     sQue = " And "
     isError = True
  End If
  
  If isError = False Then
     MsgBox "请在左边框中输入条件,然后在前面方框中打勾." & vbCrLf & vbCrLf & "如果查询时不需要该项目,请将方框中勾去掉? ", vbExclamation
     ftGuest(0).SetFocus
     Exit Sub
  End If
  
  strRecName = "Select * from tbdGuest " & sTmp
  Call Form_Activate
  
  Exit Sub
FindErr:
  MsgBox "建立查询语句错误:" & Err.Description, vbCritical
  Exit Sub

End Sub

Private Sub cmdNew_Click()

On Error Resume Next

'给出当前值,并且加上前斜杆 \
strValue = lstResult.List(lstResult.ListIndex)

If Trim(strValue) = "" Then
   Call cmdBack_Click
   Exit Sub
End If

Dim StrId As String
Dim strName As String
Dim sDeposit As String
Select Case strType
     Case "Customer"
        strName = Trim(Right$(strValue, Len(strValue) - 12))
        'sDeposit = Right(strValue, 12)
        sGuestName = Trim(Mid(strName, 1, 12))
        strValue = Trim(Left$(strValue, 12))
        strValue = GetNoPos(StrProId + strValue)
            If strValue <> "" Then
                ReservedIT StrPathId, StrProId, "Save"
                Me.Hide
                Exit Sub
            End If
    Case Else
        If strValue <> "" Then
            ReservedIT StrPathId, StrProId, "Save"
            Me.Hide
            Exit Sub
        End If
End Select
 
End Sub

Public Function GetIDs(sName As String) As String
 
 Dim DBGG As Connection
 Dim Rec As Recordset
 
 On Error Resume Next
 Set DBGG = CreateObject("ADODB.Connection")
     DBGG.Open Constr
 Set Rec = CreateObject("ADODB.Recordset")
     If IsSqlDat = True Then
     Rec.Open "Select * from tbdProduction where fldpropath Like '" & sName & "\%'", DBGG, adOpenStatic, adLockReadOnly, adCmdText
     Else
     Rec.Open "Select * from tbdProduction where fldpropath Like '" & sName & "\%'", DBGG, adOpenStatic, adLockReadOnly, adCmdText
     End If
 If Not (Rec.BOF And Rec.EOF) Then
    Do While Not Rec.EOF
       GetIDs = ",'" & Rec.Fields("fldproid") & "'" & GetIDs
       Rec.MoveNext
    Loop
   Else
   '没有找到该项目时
    GetIDs = ""
    Rec.Close
    DBGG.Close
    Exit Function
 End If
 If Left(GetIDs, 2) = ",'" Then
    GetIDs = Right(GetIDs, Len(GetIDs) - 1)
 End If
 Rec.Close
 DBGG.Close
 Set DBGG = Nothing
 
End Function

Private Sub Form_Activate()

'显示产品或用户列表数据
On Error GoTo Err1

If strType = "Customer" Then
   picCustomer.Visible = True
  Else
   picCustomer.Visible = False
End If
 
'Me.Refresh
Me.MousePointer = 11
lstResult.Clear

Set DBG = CreateObject("ADODB.Connection")
    DBG.Open Constr
Set Rec = CreateObject("ADODB.Recordset")
    Rec.Open strRecName, DBG, adOpenDynamic, adLockReadOnly, adCmdText
    
Dim strTemp As String
Dim nOX As Integer
Dim RecStore As Recordset
Dim lngNumber As Long
Dim sBBs As String
Dim IsFolder As Boolean
Dim LenID As Integer   '产品ID长度
Dim sCondition As String  '条件
Dim sPID As String  '产品ID
Dim tmpQuanty As String '数量

    nOX = GetPos(StrProId)
Select Case strType
   'OK产品选择时,
   '用户选择时
    Case "Customer"
        If Not (Rec.EOF And Rec.BOF) Then
            Rec.MoveFirst
            lstResult.Visible = False
            Do While Not Rec.EOF
               strTemp = Right$(Rec("DGUest"), Len(Rec("DGuest")) - Len(StrProId) + nOX)
               lstResult.AddItem strTemp + Space(12 - Len(strTemp)) + NullValue(Rec("DName")) + Space(53 - 12 - Len(Rec("DName"))) + "押金:[" & Rec("DDeposit") & "]"
               Rec.MoveNext
               DoEvents
            Loop
            lstResult.Visible = True
        End If
    Case Else
        If Rec.EOF And Rec.BOF Then
        Else
            Rec.MoveFirst
            lstResult.Visible = False
            Do While Not Rec.EOF
                lstResult.AddItem NullValue(Rec(strFieldName))
                Rec.MoveNext
                DoEvents
            Loop
            lstResult.Visible = True
        End If
End Select

Rec.Close
DBG.Close
Me.MousePointer = 0

Exit Sub
Err1:
    Me.MousePointer = 0
    MsgBox "错误！" + Err.Description, vbInformation
    
End Sub

Private Sub Form_Load()

 On Error Resume Next
 Me.MousePointer = 11
 GetFormSet Me, Screen
'初始化路径与返回值
 strValue = ""
 StrPathId = ""
 StrProId = ""
 
 Me.MousePointer = 0
 
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

 On Error Resume Next
 If UnloadMode = 0 Then
    '从关闭按钮关闭时
    Me.Hide
 End If
 
End Sub

Private Sub Form_Unload(Cancel As Integer)

On Error Resume Next
SaveFormSet Me
Set DBG = Nothing

End Sub

Private Sub ftGuest_Change(Index As Integer)
  
   If Index <= 4 Then
      If ftGuest(Index).Text = "" Then
         chkQuery(Index).Value = vbUnchecked
        Else
         chkQuery(Index).Value = vbChecked
      End If
   End If
   
End Sub

Private Sub ftGuest_KeyPress(Index As Integer, KeyAscii As Integer)

  If Index >= 0 And Index < 4 Then
     ftGuest(Index + 1).SetFocus
  End If
  
End Sub


Private Sub lstResult_DblClick()

  On Error Resume Next
  cmdNew_Click
  
End Sub

Private Sub lstResult_KeyPress(KeyAscii As Integer)

 On Error Resume Next
 If KeyAscii = 13 Then
    Call lstResult_DblClick
 End If
 
End Sub

Private Sub txtInput_Change()

 On Error Resume Next
 lstResult.ListIndex = SendMessage(lstResult.hwnd, LB_FINDSTRING, -1, ByVal txtInput.Text)

End Sub

Private Sub txtInput_GotFocus()

 On Error Resume Next
 txtInput.SelStart = 0
 txtInput.SelLength = Len(txtInput.Text)
 
End Sub

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

On Error Resume Next
If KeyCode = vbKeyReturn Then
  '调用双击
   Call lstResult_DblClick
End If

End Sub

Public Sub ReservedIT(sPath As String, sPro As String, sType As String)
     
  If sType = "Save" Then
    If chkReserved.Value = vbChecked Then
      Select Case strType
      Case "Production"
        SaveSetting "FHVcdHack", "Option", "Production_sPath", sPath
        SaveSetting "FHVcdHack", "Option", "Production_sPro", sPro
      Case "Customer"
        SaveSetting "FHVcdHack", "Option", "Customer_sPath", sPath
        SaveSetting "FHVcdHack", "Option", "Customer_sPro", sPro
      Case "Other"
        SaveSetting "FHVcdHack", "Option", "Other_sPath", sPath
        SaveSetting "FHVcdHack", "Option", "Other_sPro", sPro
      End Select
     Else
      Select Case strType
      '清空所有
      Case "Production"
        SaveSetting "FHVcdHack", "Option", "Production_sPath", ""
        SaveSetting "FHVcdHack", "Option", "Production_sPro", ""
      Case "Customer"
        SaveSetting "FHVcdHack", "Option", "Customer_sPath", ""
        SaveSetting "FHVcdHack", "Option", "Customer_sPro", ""
      Case "Other"
        SaveSetting "FHVcdHack", "Option", "Other_sPath", ""
        SaveSetting "FHVcdHack", "Option", "Other_sPro", ""
      End Select
    End If
   Else
    If chkReserved.Value = vbChecked Then
       Select Case strType
        Case "Production"
             StrPathId = GetSetting("FHVcdHack", "Option", "Production_sPath", "")
             StrProId = GetSetting("FHVcdHack", "Option", "Production_sPro", "")
        Case "Customer"
             StrPathId = GetSetting("FHVcdHack", "Option", "Customer_sPath", "")
             StrProId = GetSetting("FHVcdHack", "Option", "Customer_sPro", "")
        Case "Other"
             StrPathId = GetSetting("FHVcdHack", "Option", "Other_sPath", "")
             StrProId = GetSetting("FHVcdHack", "Option", "Other_sPro", "")
       End Select
      Else
       '清空所有
        Select Case strType
        Case "Production"
             StrPathId = ""
             StrProId = ""
        Case "Customer"
             StrPathId = ""
             StrProId = ""
        Case "Other"
             StrPathId = ""
             StrProId = ""
       End Select
    End If
  End If
   
  If chkReserved.Value = vbChecked Then
     SaveSetting "FHVcdHack", "Option", "Reserved", 1
    Else
     SaveSetting "FHVcdHack", "Option", "Reserved", 0
  End If
  
End Sub