clsopsell.cls

《超市进销存管理系统的开发与实现》 2、开发工具 Microsoft Visual Basic 6.0 3、运行环境 （1）、硬件环境 486DX/66MHz或更高

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsOpSell"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit

Public Sub Add(ctl As Object, strUser As String)
  Dim obj As clsSell
  Dim Result As gxcAddNew
  
   '显示添加客户对话框并获取数据
  If Not frmSell.ShowDlg(obj, vtadd, , strUser) Then Exit Sub
  '更新数据库
  Result = obj.AddNew
  If Result = AddNewOK Then
    AddToLvw obj, ctl, False
  ElseIf Result = DuplicateName_AddNew Then
    MsgBox "名称重复"
  Else
    MsgBox "错误"
  End If
  

End Sub


Public Sub Modify(ctl As Object, strUser As String)
  Dim obj As clsSell
  Dim strName As String
  
  '获取树上选中的客户类型，如果没有选中的对象则退出函数
  If GetObjFromControl(ctl, obj) = False Then
    MsgBox "请选择商品类型"
    Exit Sub
  End If
  
  '显示添加客户对话框并获取数据
  If Not frmSell.ShowDlg(obj, vtModify, , strUser) Then Exit Sub
  '更新数据库
  Dim Result As gxcUpdate
  Result = obj.Update
  If Result = UpdateOK Then
    '将客户类型加入树型图
    AddToLvw obj, ctl, True
  ElseIf Result = DuplicateName_Update Then
    MsgBox "名称重复"
  Else
    MsgBox "错误"
  End If
  
End Sub

Public Sub Delete(ctl As Object)
  Dim obj As clsSell
  Dim Result As gxcDelete
  
  '获取树上选中的客户类型，如果没有选中的对象则退出函数
  If GetObjFromControl(ctl, obj) = False Then
    MsgBox "请选择销售记录"
    Exit Sub
  End If
  
  If MsgBox("真的要删除吗？", vbQuestion + vbYesNo + _
            vbDefaultButton2) = vbNo Then Exit Sub
  
  '从数据库中删除
  Result = obj.Delete
  If Result = DeleteFail Then
    MsgBox "删除失败！"
  ElseIf Result = DeleteOK Then
    '来到这，说明删除成功，从树形图中删除节点
    ctl.ListItems.Remove ctl.SelectedItem.index
  End If

End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'将单个客户加入列表，或在列表中更新
'特意将该函数单独做出来，而没有将本函数中的代码完全在MerchsToListview函数中实现
'Why?
'因为在设计该功能时，你还应考虑到在以后的编程过程中，很可能要用到
'将某个单独的“商品”对象加入列表框（比如新增加了一个客户）。
Public Sub AddToLvw(ByVal obj As clsSell, _
                          ByRef lvw As Object, _
                          ByVal IsOverWrite As Boolean)
  '第三个参数如果是TRUE，则说明是更新当前已存在的某个列表项，否则是新加一个列表项
  Dim Itm As ListItem
  Dim sIcon As String
  Dim bIcon As String
  
  '图标关键字
  sIcon = "sboy"
  bIcon = "bboy"
  
  '如果是更新（即覆盖），则使用当前选种的元素
  If IsOverWrite Then
    Set Itm = lvw.SelectedItem
    If Itm Is Nothing Then Exit Sub
  Else
    Set Itm = lvw.ListItems.Add(, "A" & obj.ID, , bIcon, sIcon)
  End If
  With obj  '这里要与InitMerchListview相对应
    Itm.SmallIcon = sIcon
    Itm.Icon = bIcon
    Itm.Text = .MerchName
    Itm.SubItems(1) = .Count
    Itm.SubItems(2) = "件/个"
    Itm.SubItems(3) = .SellPrice
    Itm.SubItems(4) = .RegDate
    Itm.SubItems(5) = .OperatorId
    Itm.SubItems(6) = .Remark
  End With
  Set Itm = Nothing
End Sub

Public Sub AnaAddToLvw(ByVal obj As clsSell, _
                          ByRef lvw As Object, _
                          ByVal IsOverWrite As Boolean)
  '第三个参数如果是TRUE，则说明是更新当前已存在的某个列表项，否则是新加一个列表项
  Dim Itm As ListItem
  Dim sIcon As String
  Dim bIcon As String
  
  '图标关键字
  sIcon = "sboy"
  bIcon = "bboy"
  
  '如果是更新（即覆盖），则使用当前选种的元素
  If IsOverWrite Then
    Set Itm = lvw.SelectedItem
    If Itm Is Nothing Then Exit Sub
  Else
    Set Itm = lvw.ListItems.Add(, "A" & obj.ID, , bIcon, sIcon)
  End If
  With obj  '这里要与InitMerchListview相对应
    Itm.SmallIcon = sIcon
    Itm.Icon = bIcon
    Itm.Text = .TypeName
    Itm.SubItems(1) = .MerchName
    Itm.SubItems(2) = .RegTimes
    Itm.SubItems(3) = .TotalPrice
    Itm.SubItems(4) = "元"
  End With
  Set Itm = Nothing
End Sub

'按照“商品”设置ListView的显示样式
Public Sub InitListview(ByRef lvw As Object)
  With lvw
    .ColumnHeaders.Clear
    '加入四个列首
    .ColumnHeaders.Add , , "商品名称", 1500
    .ColumnHeaders.Add , , "数量", 800
    .ColumnHeaders.Add , , "单位", 800
    .ColumnHeaders.Add , , "售出单价", 1000
    .ColumnHeaders.Add , , "登记日期", 1300
    .ColumnHeaders.Add , , "操作员", 1500
    .ColumnHeaders.Add , , "备注", 2500
  End With
  
End Sub

'按照“商品”设置ListView的显示样式
Public Sub AnaInitListview(ByRef lvw As Object)
  With lvw
    .ColumnHeaders.Clear
    '加入列首
    .ColumnHeaders.Add , , "商品类型", 1500
    .ColumnHeaders.Add , , "商品名称", 1500
    .ColumnHeaders.Add , , "售出登记次数", 1500
    .ColumnHeaders.Add , , "售出总价", 1500
    .ColumnHeaders.Add , , "单位", 800
  End With
  
End Sub

'将客数据合显示到ListView中
Public Sub ObjsToListView(ByVal objs As clsSells, ByRef lvw As Object)
  '传入参数为客户的集合类与列表框
  Dim i As Long
  
  '如果列表还未初始化，则初始化之(你可以采用其它方法判断是否初始化，这里是个笨办法)
  If lvw.ColumnHeaders.Count = 0 Then InitListview lvw
  lvw.ListItems.Clear '清除当前的列表内容
  
  For i = 1 To objs.Count
    '将每个“商品”都加入到该列表中，调用了单独的函数，没有全部做到这
    '个函数中，为什么呢？参看AddMerchToLvw函数
    AddToLvw objs.Item(i), lvw, False
  Next i
End Sub

'将客数据合显示到ListView中
Public Sub AnaObjsToListView(ByVal objs As clsSells, ByRef lvw As Object)
  '传入参数为客户的集合类与列表框
  Dim i As Long
  
  '如果列表还未初始化，则初始化之(你可以采用其它方法判断是否初始化，这里是个笨办法)
  AnaInitListview lvw
  lvw.ListItems.Clear '清除当前的列表内容
  
  For i = 1 To objs.Count
    '将每个“商品”都加入到该列表中，调用了单独的函数，没有全部做到这
    '个函数中，为什么呢？参看AddMerchToLvw函数
    AnaAddToLvw objs.Item(i), lvw, False
  Next i
End Sub

' 显示全部客户到列表控件
Public Sub FillListView(ByRef lvw As Object, Optional lngTypeId As Long = 0)
  Dim objs As New clsSells
  Dim rstObjs As clsSells
  
  'Find的参数取默认值，此时查找全部
  Set rstObjs = objs.Find(, lngTypeId)
  
  '检查是否找到数据
  If rstObjs Is Nothing Then
    Exit Sub
  End If
  
  '将查找到的客户集合添加到列表控件中
  ObjsToListView rstObjs, lvw
  
  Set objs = Nothing
  Set rstObjs = Nothing
  
End Sub

Public Sub FindStorage(ByRef lvw As Object, _
                      Optional IsDesc As Boolean = True, _
                      Optional nCount As Integer = 10)
  Dim objs As New clsSells
  Dim rstObjs As clsSells
  
  'Find的参数取默认值，此时查找全部
  Set rstObjs = objs.FindStorage(IsDesc, nCount)
  
  '检查是否找到数据
  If rstObjs Is Nothing Then
    Exit Sub
  End If
  
  '将查找到的客户集合添加到列表控件中
  AnaObjsToListView rstObjs, lvw
  
  Set objs = Nothing
  Set rstObjs = Nothing
  
End Sub

'从列表或树型图中得到一个客户对象
Public Function GetObjFromControl(ByVal lvw As Object, _
                                    ByRef obj As clsSell) As Boolean
  '如果列表中没有被选择的项，则直接退出
  If lvw.SelectedItem Is Nothing Then
    GetObjFromControl = False
    Exit Function
  End If

  Dim objs As New clsSells
  Dim ID As Long
  '去除Listview中列表项的KEY属性前的字母“A”，即为该客户的ID值
  ID = GetID(lvw.SelectedItem.Key)

  On Error Resume Next '为了防止未查找到，因此加入了错误判断语句
  Set obj = objs.Find(ID).Item(1)
  GetObjFromControl = (Err.Number = 0)
End Function