frmmemberselect.frm

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

      FullRowSelect   =   -1  'True
      GridLines       =   -1  'True
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      NumItems        =   9
      BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         Text            =   "编号与卡号"
         Object.Width           =   2469
      EndProperty
      BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   1
         Text            =   "姓名"
         Object.Width           =   1764
      EndProperty
      BeginProperty ColumnHeader(3) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         Alignment       =   2
         SubItemIndex    =   2
         Text            =   "性别"
         Object.Width           =   1058
      EndProperty
      BeginProperty ColumnHeader(4) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   3
         Text            =   "电话"
         Object.Width           =   2822
      EndProperty
      BeginProperty ColumnHeader(5) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   4
         Text            =   "手机"
         Object.Width           =   1764
      EndProperty
      BeginProperty ColumnHeader(6) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   5
         Text            =   "地址"
         Object.Width           =   2646
      EndProperty
      BeginProperty ColumnHeader(7) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         Alignment       =   1
         SubItemIndex    =   6
         Text            =   "消费累计"
         Object.Width           =   1764
      EndProperty
      BeginProperty ColumnHeader(8) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   7
         Text            =   "会员等级"
         Object.Width           =   1764
      EndProperty
      BeginProperty ColumnHeader(9) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         Alignment       =   1
         SubItemIndex    =   8
         Text            =   "卡金额"
         Object.Width           =   1764
      EndProperty
   End
   Begin VB.Menu mnuControl 
      Caption         =   "会员查询选择(&C)"
      Begin VB.Menu mnuMemberSelect 
         Caption         =   "选定该会员(&Select)"
         Shortcut        =   {DEL}
      End
      Begin VB.Menu LIne02 
         Caption         =   "-"
      End
      Begin VB.Menu mnuMemberSearch 
         Caption         =   "会员查询(&Find)"
         Shortcut        =   {F3}
      End
      Begin VB.Menu mnuRefresh 
         Caption         =   "显示所有会员(&All)"
         Shortcut        =   {F4}
      End
      Begin VB.Menu Line202 
         Caption         =   "-"
      End
      Begin VB.Menu mnuExit 
         Caption         =   "关闭返回(E&xit)"
         Shortcut        =   ^X
      End
   End
End
Attribute VB_Name = "frmMemberSelect"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit


Private Sub cmdCancel_Click()

  Unload Me
  
End Sub



Private Sub cmdSearch_Click()

 Dim sTmp As String
 Dim sAnd As String
     sAnd = " Where "
      
 If Trim(ftID.Text) <> "" Then
    If chkSearch.Value = vbChecked Then
        sTmp = sTmp & sAnd & " ID Like '%" & Trim(ftID.Text) & "%'"
       Else
        sTmp = sTmp & sAnd & " ID='" & Trim(ftID.Text) & "'"
    End If
    sAnd = " And "
 End If
 
 If Trim(ftCName.Text) <> "" Then
    If chkSearch.Value = vbChecked Then
       sTmp = sTmp & sAnd & " Name Like '%" & Trim(ftCName.Text) & "%'"
      Else
       sTmp = sTmp & sAnd & " Name='" & Trim(ftCName.Text) & "'"
    End If
    sAnd = " And "
 End If
 
 If Trim(ftTel.Text) <> "" Then
    If chkSearch.Value = vbChecked Then
       sTmp = sTmp & sAnd & " Tel Like '%" & Trim(ftTel.Text) & "%'"
      Else
       sTmp = sTmp & sAnd & " Tel='" & Trim(ftTel.Text) & "'"
    End If
    sAnd = " And "
 End If

 If Trim(ftFax.Text) <> "" Then
     If chkSearch.Value = vbChecked Then
        sTmp = sTmp & sAnd & " Fax Like '%" & Trim(ftFax.Text) & "%'"
       Else
        sTmp = sTmp & sAnd & " Fax='" & Trim(ftFax.Text) & "'"
     End If
    sAnd = " And "
 End If

 If Trim(ftEmail.Text) <> "" Then
    If chkSearch.Value = vbChecked Then
      sTmp = sTmp & sAnd & " Email Like '%" & Trim(ftEmail.Text) & "%'"
      Else
      sTmp = sTmp & sAnd & " Email='" & Trim(ftEmail.Text) & "'"
    End If
    sAnd = " And "
 End If

 If Trim(ftAddress.Text) <> "" Then
    If chkSearch.Value = vbChecked Then
       sTmp = sTmp & sAnd & " Address Like '%" & Trim(ftAddress.Text) & "%'"
      Else
       sTmp = sTmp & sAnd & " Address='" & Trim(ftAddress.Text) & "'"
    End If
    sAnd = " And "
 End If

 If cmbLevel.Text <> "" Then
    sTmp = sTmp & sAnd & " DLevel=" & cmbLevel.ListIndex - 1
 End If
 
 '刷新会员列表
  sFindString = sTmp
  LoadData

End Sub

Private Sub Form_Load()
   
  GetFormSet Me, Screen
  sFindString = ""
  
  sGuestID = "": sGuestName = "": sGuestTel = ""
  cGuestRemain = 0
  
  LoadData

End Sub

Private Sub Form_Resize()
  
  On Error Resume Next
  
  If Me.WindowState = 1 Then Exit Sub
  
 '浏览带
  lstPro.Left = 100
  lstPro.Width = Me.Width - 300
  lstPro.Height = Me.Height - Frame1.Height - 850

  Frame1.Width = Me.Width - 350
  'cmdCancel.Left = Me.Width - cmdCancel.Width - 400

End Sub

Private Sub Form_Unload(Cancel As Integer)

  On Error Resume Next
  SaveFormSet Me

End Sub


Private Sub lstPro_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)

 On Error Resume Next
 
'排序操作
 If lstPro.ListItems.Count > 0 Then
 
    lstPro.SortKey = ColumnHeader.Index - 1
    lstPro.Sorted = True
    
    If lstPro.SortOrder = lvwAscending Then
       lstPro.SortOrder = lvwDescending
       Else
       lstPro.SortOrder = lvwAscending
    End If
    
 End If

End Sub

Private Sub lstPro_DblClick()

  '选定该会员
   If lstPro.ListItems.Count = 0 Then
      Exit Sub
   End If
   If lstPro.SelectedItem.Text = "" Then
      Exit Sub
   End If
     
  '给出选定内容
   sGuestID = lstPro.SelectedItem.Text
   sGuestName = lstPro.SelectedItem.SubItems(1)
   sGuestTel = lstPro.SelectedItem.SubItems(3)
   If IsNumeric(lstPro.SelectedItem.SubItems(8)) Then
      cGuestRemain = CCur(lstPro.SelectedItem.SubItems(8))
     Else
      cGuestRemain = 0
   End If
  '御载对象
   Unload Me
          
End Sub

Private Sub lstPro_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)

  If Button = 2 Then
     If lstPro.ListItems.Count = 0 Then
        mnuMemberSelect.Enabled = False
        Exit Sub
     End If
     If lstPro.SelectedItem.Text = "" Then
        mnuMemberSelect.Enabled = False
     Else
        mnuMemberSelect.Enabled = True
     End If
      PopupMenu mnuControl
  End If

End Sub

Private Sub mnuControl_Click()
     
     If lstPro.ListItems.Count = 0 Then
        mnuMemberSelect.Enabled = False
        Exit Sub
     End If
     If lstPro.SelectedItem.Text = "" Then
        mnuMemberSelect.Enabled = False
     Else
        mnuMemberSelect.Enabled = True
     End If

End Sub

Private Sub MnuExit_Click()

  Call cmdCancel_Click
  
End Sub

Private Sub mnuMemberSearch_Click()

  cmdSearch_Click
  
End Sub

Private Sub mnuMemberSelect_Click()
 
  Call lstPro_DblClick
  
End Sub

Public Sub mnuRefresh_Click()
  
   sFindString = "" '查询字符串为空
  '安装数据
   LoadData

End Sub

Public Sub LoadData()

    On Error GoTo Err_init

    Me.MousePointer = 11
    
    Dim DB As Connection, EF As Recordset
    Set DB = CreateObject("ADODB.Connection")
    Set EF = CreateObject("ADODB.Recordset")
        DB.Open Constr
        EF.Open "Select * from tbdmember" & sFindString, DB, adOpenStatic, adLockReadOnly, adCmdText
        lstPro.Visible = False
        lstPro.ListItems.Clear
        
        If Not (EF.EOF And EF.BOF) Then
           Do While Not EF.EOF
              InsertToMember lstPro, EF("ID"), EF("Name"), EF("Sex"), EF("Tel"), NullValue(EF("Mobil")), NullValue(EF("Address")), EF("Dconsum"), EF("DLevel"), EF("Consume")
              EF.MoveNext
              DoEvents
           Loop
        End If
        EF.Close
        DB.Close
        Set EF = Nothing
        Set DB = Nothing
        
        lstPro.Visible = True
        Me.MousePointer = 0
        
   Exit Sub
Err_init:
   Me.MousePointer = 0
   MsgBox "网络配置错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Sub InsertToMember(tmpView As ListView, sText1 As String, sText2 As String, sText3 As String _
      , sText4 As String, sText5 As String, sText6 As String, sText7 As String, sText8 As String, sText9 As String)
 
   On Error Resume Next
   
   If Trim(sText1) = "" Then Exit Sub
   
   Dim lstTmp As ListItem
   Set lstTmp = tmpView.ListItems.Add
       lstTmp.Text = Trim(sText1)
       lstTmp.SubItems(1) = Trim(sText2)
       lstTmp.SubItems(2) = Trim(sText3)
       lstTmp.SubItems(3) = Trim(sText4)
       lstTmp.SubItems(4) = Trim(sText5)
       lstTmp.SubItems(5) = Trim(sText6)
       lstTmp.SubItems(6) = Format(sText7, "0.00")
       Select Case sText8
        Case "0"
          lstTmp.SubItems(7) = "普通会员"
        Case "1"
          lstTmp.SubItems(7) = "初级会员"
        Case "2"
          lstTmp.SubItems(7) = "中级会员"
        Case "3"
          lstTmp.SubItems(7) = "高级会员"
       End Select
       lstTmp.SubItems(8) = Format(sText9, "0.00")
End Sub