frmmember.frm

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

    ptGrid.N_Cols = "1,2,3,4,5,6,7,8,9"
    Set ptGrid.N_Grid = lstPro
    ptGrid.N_TiTle = "【会员列表】"
    ptGrid.N_Head10 = "制表人：" & UserText
    ptGrid.N_Head2 = "制表时间：" & Now
    ptGrid.N_PageLeft = XLeft
    ptGrid.N_PageTop = XTop
    ptGrid.N_PageHeight = 290
    ptGrid.N_PageWidth = 200
    ptGrid.N_RowHeight = 6
    ptGrid.PrintPage
    
    Set ptGrid = Nothing
  
 Exit Sub
Err1:
  MsgBox "对不起,打印列表错误。  " & vbCrLf & vbCrLf & Err.Description, vbInformation
  Exit Sub

End Sub

Private Sub cmdSearch_Click()

  sFindString = ""
  frmMemberSearch.Show 1
  
  '安装数据
   If sFindString = "" Then Exit Sub
   LoadData
   
End Sub

Private Sub Form_Load()
   
  GetFormSet Me, Screen
  MemberFocus = True
  sFindString = ""
  
  frmMain.lbControl.Caption = "会员管理中心"
  LoadData

End Sub

Private Sub Form_Resize()
  
  On Error Resume Next
  
  If Me.WindowState = 1 Then Exit Sub
        
  '常规时
  If Me.WindowState = 0 Then
     Me.Move 1, 1, frmMain.Width - (frmMain.picTool.Width + 200), frmMain.Height - (frmMain.picADV.Height + 1150)
  End If
  
 '浏览带
  lstPro.Left = 100
  lstPro.Width = Me.Width - 300
  lstPro.Height = Me.Height - Frame1.Height - 550

  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
  MemberFocus = False
  frmMain.lbControl.Caption = "收银控制中心"

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
  If lstPro.SelectedItem.Text = "" Then Exit Sub
  
 '显示会员详细
  frmViewForm.Show 1
  
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
        mnuMemberDel.Enabled = False
        mnuMemberModify.Enabled = False
        mnuDetail.Enabled = False
        PopupMenu mnuControl
        Exit Sub
     End If
     If lstPro.SelectedItem.Text = "" Then
        mnuMemberDel.Enabled = False
        mnuMemberModify.Enabled = False
        mnuDetail.Enabled = False
     Else
        mnuMemberDel.Enabled = True
        mnuMemberModify.Enabled = True
        mnuDetail.Enabled = True
     End If
      PopupMenu mnuControl
  End If

End Sub

Private Sub mnuAdd_Click()

 If lstPro.ListItems.Count = 0 Then Exit Sub
 If lstPro.SelectedItem.Text = "" Then
    MsgBox "请选定需要充值的会员,然后按充值按钮？    ", vbExclamation, "Design By Yusilong."
    Exit Sub
  Else
   frmAddForm.Show 1
 End If

End Sub

Private Sub mnuBack_Click()

  If lstPro.ListItems.Count = 0 Then Exit Sub
  If lstPro.SelectedItem.Text = "" Then
     MsgBox "请选定需要退卡的会员,然后按退卡菜单？", vbExclamation, "Design By Yusilong."
     Exit Sub
  End If
  If MsgBox("真的要退卡吗，退卡后，卡内金额为空？（Y/N）  ", vbYesNo + vbInformation + vbDefaultButton2) = vbNo Then Exit Sub
   
  BackMemberCard lstPro.SelectedItem.Text, CCur(lstPro.SelectedItem.SubItems(6))
  
  '刷新列表
  LoadData
  
End Sub

'退卡操作
Public Sub BackMemberCard(sWP As String, curTmp As Currency)

   On Error GoTo Err_init
   
   Dim DB As Connection
      
   Set DB = CreateObject("ADODB.COnnection")
       DB.Open Constr
       DB.BeginTrans
       
      '建立退卡
       If BackCard(DB, curTmp, sWP) = False Then
          DB.RollbackTrans
          DB.Close
          Set DB = Nothing
          Exit Sub
       End If
       
       DB.CommitTrans
       DB.Close
       Set DB = Nothing
      
       Exit Sub
Err_init:
  MsgBox "退卡错误:" & vbCrLf & vbCrLf & Err.Description, vbCritical
  On Error Resume Next
  DB.RollbackTrans
  DB.Close
  Set DB = Nothing
  
End Sub

Private Sub mnuCard_Click()

  If lstPro.ListItems.Count = 0 Then Exit Sub
  If lstPro.SelectedItem.Text = "" Then
     MsgBox "请选定需要对帐的会员,然后按会员卡对帐菜单？    ", vbExclamation, "Design By Yusilong."
     Exit Sub
   Else
     frmShowCard.stmpMember = lstPro.SelectedItem.Text
     frmShowCard.Show 1
  End If

End Sub

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

End Sub

Private Sub mnuDetail_Click()

  Call lstPro_DblClick
  
End Sub

Private Sub MnuExit_Click()

  Call cmdCancel_Click
  
End Sub

Private Sub mnuMemberAdd_Click()

   Call cmdAdd_Click
   
End Sub

Private Sub mnuMemberDel_Click()

   Call cmdDel_Click
   
End Sub

Private Sub mnuMemberModify_Click()

  Call cmdModify_Click
  
End Sub

Private Sub mnuMemberSearch_Click()

  Call cmdSearch_Click
  
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"), NullValue(EF("Tel")), NullValue(EF("Mobil")), NullValue(EF("Address")), NullValue(EF("Consume")), NullValue(EF("Dconsum")), EF("DLevel")
              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")
       lstTmp.SubItems(7) = Format(sText8, "0.00")
       Select Case sText9
        Case "0"
          lstTmp.SubItems(8) = "普通会员"
        Case "1"
          lstTmp.SubItems(8) = "初级会员"
        Case "2"
          lstTmp.SubItems(8) = "中级会员"
        Case "3"
          lstTmp.SubItems(8) = "高级会员"
       End Select
End Sub