frmmember.frm

这是一套超市完整的代码

         value           =   0   'False
         cback           =   -2147483633
      End
      Begin VB.Label Label3 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "消费金额："
         Height          =   180
         Left            =   360
         TabIndex        =   13
         Top             =   915
         Width           =   900
      End
      Begin VB.Label Label2 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "会员卡号："
         Height          =   180
         Left            =   360
         TabIndex        =   12
         Top             =   435
         Width           =   900
      End
      Begin VB.Label Label5 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "登记日期："
         Height          =   180
         Left            =   360
         TabIndex        =   11
         Top             =   1380
         Width           =   900
      End
   End
   Begin VB.Label Label4 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "卡号："
      Height          =   180
      Left            =   240
      TabIndex        =   14
      Top             =   720
      Width           =   540
   End
End
Attribute VB_Name = "frmMember"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Sub cmdAdd_Click()
On Error GoTo aaaa
    txtCard.Text = Trim(txtCard.Text)
    If txtCard.Text = "" Then txtCard.SetFocus: Exit Sub
    Dim i As Long
    For i = 1 To List1.ListItems.Count
        If StrComp(txtCard.Text, List1.ListItems(i).SubItems(1), 1) = 0 Then
            List1.ListItems(i).Selected = True
            SetSB 2, "找到会员卡 " & txtCard.Text & " ."
            txtCard.Text = ""
            txtCard.SetFocus
            Exit Sub
        End If
    Next
    cnMain.Execute "insert [Member] values('" & txtCard.Text & "',0,'" & FormatDate(Date) & "')"
    Dim Item As ListItem
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    rs.Open "Select TOP 1 * From [Member] order by MemberID Desc", cnMain, 1, 1
    b = CheckOutDate(CDate(rs("RegDate")))
    Set Item = List1.ListItems.Add(1, , rs("MemberID"), , 1)
    Item.SubItems(1) = rs("MemberCard")
    Item.SubItems(2) = rs("TotalCost")
    Item.SubItems(3) = rs("RegDate")
    Item.SubItems(4) = "正常"
    Item.Selected = True
    SetSB 2, "已添加会员卡 " & txtCard.Text & " ."
    txtCard.Text = ""
    txtCard.SetFocus
Exit Sub
aaaa:
    MsgBox Err.Description, vbCritical
    txtCard.SetFocus
End Sub

Public Function FormatDate(ByVal d As Date) As String
    FormatDate = Format(d, "yyyy-mm-dd")
End Function

Private Sub cmdClear_Click()
On Error GoTo aaaa
    Dim i As Long, j As Long, k As Long
    j = List1.ListItems.Count
    If j <= 0 Then
        MsgBox "会员列表为空！", vbInformation
        txtCard.SetFocus
        Exit Sub
    End If
    If MsgBox("这个操作会清理所有的过期会员，请问继续吗？", vbOKCancel + vbExclamation + vbDefaultButton2) = vbCancel Then
        txtCard.SetFocus
        Exit Sub
    End If
    For i = j To 1 Step -1
        If List1.ListItems(i).SmallIcon = 2 Then
            cnMain.Execute "Delete From [Member] Where MemberCard='" & List1.ListItems(i).SubItems(1) & "'"
            List1.ListItems.Remove i
            k = k + 1
        End If
    Next
    MsgBox "清理过程顺利完成，请看以下统计数据：" & vbCrLf & vbCrLf & "原来会员个数： " & j & vbCrLf & "过期会员个数： " & k & vbCrLf & "现在会员个数： " & List1.ListItems.Count, vbInformation
    SetSB 2, "清理过程顺利完成."
    txtCard.SetFocus
Exit Sub
aaaa:
    MsgBox Err.Description, vbCritical
    LoadMemberList
    txtCard.SetFocus
End Sub

Private Sub cmdDel_Click()
On Error GoTo aaaa
    Dim Item As ListItem
    Set Item = List1.SelectedItem
    If MsgBox("确定删除会员 " & Item.SubItems(1) & " 吗", vbInformation + vbOKCancel) = vbCancel Then Exit Sub
    cnMain.Execute "Delete From [Member] Where MemberCard='" & Item.SubItems(1) & "'"
    SetSB 2, "删除会员卡 " & Item.SubItems(1) & " 成功."
    List1.ListItems.Remove Item.Index
    txtCard.SetFocus
Exit Sub
aaaa:
    If Err.Number <> 91 Then MsgBox Err.Description, vbCritical
End Sub

Private Sub cmdEdit_Click()
On Error GoTo aaaa
    Dim Item As ListItem
    Set Item = List1.SelectedItem
    txtCard2.Text = Item.SubItems(1)
    txtCard2.Tag = Item.SubItems(1)
    txtCost.Text = Item.SubItems(2)
    txtCost.Tag = Item.SubItems(2)
    txtDate.Text = Item.SubItems(3)
    txtDate.Tag = Item.SubItems(3)
    ShowItemFrame True
    txtCard2.SetFocus
aaaa:
End Sub

Private Sub cmdExit_Click()
    ShowItemFrame False
    txtCard.SetFocus
End Sub

Private Sub cmdOK_Click()
On Error GoTo aaaa
    txtCard2.Text = Trim(txtCard2.Text)
    If txtCard2.Text = "" Then
        MsgBox "必须填写会员卡号。", vbInformation
        txtCard2.SetFocus
        Exit Sub
    End If
    cnMain.Execute "UPDATE [Member] SET MemberCard='" & txtCard2.Text & "',TotalCost=" & txtCost.Text & ",RegDate='" & txtDate.Text & "' Where MemberCard='" & txtCard2.Tag & "'"
    Dim Item As ListItem, b As Boolean
    b = CheckOutDate(CDate(txtDate.Text))
    Set Item = List1.SelectedItem
    Item.SmallIcon = IIf(b = False, 1, 2)
    Item.SubItems(1) = txtCard2.Text
    Item.SubItems(2) = txtCost.Text
    Item.SubItems(3) = txtDate.Text
    Item.SubItems(4) = IIf(b = False, "正常", "过期")
    SetSB 2, "修改会员卡 " & txtCard2.Text & " 成功."
    cmdExit_Click
Exit Sub
aaaa:
    MsgBox "操作失败，可能是该会员卡号已经存在！", vbCritical
End Sub

Private Sub cmdToday_Click()
    txtDate.Text = FormatDate(Date)
End Sub

Private Sub Form_Load()
    Me.WindowState = 2
    imgIcon.Picture = frmMain.cmdLeft(5).Picture
    '读取会员数据列表
    LoadMemberList
End Sub

'读取会员数据列表
Public Sub LoadMemberList()
    Dim Item As ListItem, b As Boolean
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    List1.ListItems.Clear
    rs.Open "Select * From [Member] order by MemberID Desc", cnMain, 1, 1
    Do Until rs.EOF
        b = CheckOutDate(CDate(rs("RegDate")))
        Set Item = List1.ListItems.Add(, , rs("MemberID"), , IIf(b = False, 1, 2))
        Item.SubItems(1) = rs("MemberCard")
        Item.SubItems(2) = rs("TotalCost")
        Item.SubItems(3) = rs("RegDate")
        Item.SubItems(4) = IIf(b = False, "正常", "过期")
        rs.MoveNext
    Loop
    SetSB 2, "共 " & rs.RecordCount & " 条会员记录."
End Sub

Public Function CheckOutDate(ByVal d As Date) As Boolean
    Dim j1 As Long, j2 As Long, j3 As Long
    j1 = Year(Date) - Year(d)
    j2 = Month(Date) - Month(d)
    j3 = Day(Date) - Day(d)
    If j1 > 1 Then
        CheckOutDate = True
    Else
        CheckOutDate = (j1 + j2 + j3 > 0)
    End If
End Function

Public Sub ShowItemFrame(ByVal b As Boolean)
    List1.Visible = Not b
    freItem.Visible = b
    cmdDel.Enabled = Not b
    cmdClear.Enabled = Not b
    cmdEdit.Enabled = Not b
    cmdAdd.Enabled = Not b
    txtCard.Enabled = Not b
    cmdAdd.Default = Not b
    cmdOK.Default = b
End Sub

Private Sub Form_Resize()
On Error Resume Next
    List1.Width = Width / 15 - 38
    List1.Height = Me.Height / 15 - 144
    PicTop.Width = Width / 15 - 16
    Cls
    Line (2, 2)-(Width / 15 - 14, Height / 15 - 29), 10921638, B
End Sub

Private Sub List1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
On Error Resume Next
    With List1
        If (ColumnHeader.Index - 1) = .SortKey Then
            .SortOrder = 1 - .SortOrder
            .Sorted = True
        Else
            .Sorted = False
            .SortOrder = 0
            .SortKey = ColumnHeader.Index - 1
            .Sorted = True
        End If
    End With
End Sub

Private Sub List1_DblClick()
On Error GoTo aaaa
    Dim j As Long
    j = List1.SelectedItem.Index
    cmdEdit_Click
aaaa:
End Sub

Private Sub List1_KeyDown(KeyCode As Integer, Shift As Integer)
On Error GoTo aaaa
    If KeyCode = vbKeyDelete Then
        Dim j As Long
        j = List1.SelectedItem.Index
        cmdDel_Click
    End If
aaaa:
End Sub

Private Sub txtCost_LostFocus()
On Error GoTo aaaa
    Dim c As Currency
    c = CCur(txtCost.Text)
Exit Sub
aaaa:
    txtCost.Text = txtCost.Tag
End Sub

Private Sub txtDate_LostFocus()
On Error GoTo aaaa
    Dim d As Date
    d = CDate(txtDate.Text)
Exit Sub
aaaa:
    txtDate.Text = txtDate.Tag
End Sub