clsopadmin.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 = "clsOpAdmin"
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

Private mvarAccount As String   '局部复制
Public Property Let Account(ByVal vData As String)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.IsDefault = 5
mvarAccount = vData
End Property


Public Property Get Account() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.IsDefault
    Account = mvarAccount
End Property

'==============================================================
'
' 处理增、删、改
'
'===============================================================
Public Sub Add(ctl As Object)
  Dim obj As clsAdmin
  Dim Result As gxcAddNew
  
  '显示添加客户对话框并获取数据
  If Not frmUser.ShowDlg(obj, vtadd) 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)
  Dim obj As clsAdmin
  Dim strName As String
  
  '获取树上选中的客户类型，如果没有选中的对象则退出函数
  If GetObjFromControl(ctl, obj) = False Then
    MsgBox "请选择用户类型"
    Exit Sub
  End If
  
  '显示添加客户对话框并获取数据
  If Not frmUser.ShowDlg(obj, vtModify) 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 clsAdmin
  Dim Result As gxcDelete
  
  '获取树上选中的客户类型，如果没有选中的对象则退出函数
  If GetObjFromControl(ctl, obj) = False Then
    MsgBox "请选择供应商类型"
    Exit Sub
  End If
  
  '无法删除系统默认帐号
  If obj.IsDefault = True Then
    MsgBox "无法删除系统默认帐号", vbExclamation + vbOKOnly
    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.Nodes.Remove ctl.SelectedItem.index
    ctl.ListItems.Remove ctl.SelectedItem.index
  End If

End Sub


'==============================================================
'
' 处理ListView控件：AddToLvw，InitListview, ObjsToListView,
'                   FillListView, GetObjFromControl
'
'===============================================================

'将单个客户加入列表，或在列表中更新
'特意将该函数单独做出来，而没有将本函数中的代码完全在MerchsToListview函数中实现
'Why?
'因为在设计该功能时，你还应考虑到在以后的编程过程中，很可能要用到
'将某个单独的“商品”对象加入列表框（比如新增加了一个客户）。
Public Sub AddToLvw(ByVal obj As clsAdmin, _
                          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.Account, , bIcon, sIcon)
  End If
  With obj  '这里要与InitMerchListview相对应
    Itm.SmallIcon = sIcon
    Itm.Icon = bIcon
    Itm.Text = .Account
    Itm.SubItems(1) = "*******"
    Itm.SubItems(2) = IIf(.IsDefault, "默认用户", "新增用户")
  End With
  Set Itm = Nothing
End Sub


'按照“商品”设置ListView的显示样式
Public Sub InitListview(ByRef lvw As Object)
  With lvw
    .ColumnHeaders.Clear
    '加入四个列首
'    .ColumnHeaders.Add , , "编号", 1200
    .ColumnHeaders.Add , , "用户名", 1200
    .ColumnHeaders.Add , , "密码", 1500
    .ColumnHeaders.Add , , "级别", 1000
  End With
End Sub

'将客户集合显示到ListView中
Public Sub ObjsToListView(ByVal objs As clsAdmins, 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

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


End Sub

'得到某个节点或列表项所表示的对象的实际ID，如“A11”，则得到11，“B2”，则得到2
Private Function GetAccount(strKey As String) As String
  GetAccount = Right(strKey, Len(strKey) - 1)
End Function

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

  Dim objs As New clsAdmins
  Dim Account As String
  '去除Listview中列表项的KEY属性前的字母“A”，即为该客户的ID值
  Account = GetAccount(lvw.SelectedItem.Key)
  On Error Resume Next '为了防止未查找到，因此加入了错误判断语句
  Set obj = objs.Find(Account).Item(1)
  GetObjFromControl = (Err.Number = 0)
End Function

'==============================================================
'
' 处理Combo控件：FillCombo，ObjsToCombo
'
'===============================================================
Private Sub ObjsToCombo(ByVal objs As clsAdmins, ByRef cbo As ComboBox)
  '传入参数为客户的集合类与列表框
  Dim i As Long
  
  cbo.Clear '清除当前的列表内容
  
  For i = 1 To objs.Count
    '将每个“商品”都加入到该列表中，调用了单独的函数，没有全部做到这
    '个函数中，为什么呢？参看AddClientToLvw函数
    Call cbo.AddItem(objs.Item(i).Account, i - 1)
    cbo.ItemData(i - 1) = objs.Item(i).Account
  Next i
  
End Sub

Public Sub FillCombo(ByRef cbo As Object)
  Dim objs As New clsAdmins
  Dim rstObjs As clsAdmins
  
  Set rstObjs = objs.Find
  ObjsToCombo rstObjs, cbo
  
  Set objs = Nothing
  Set rstObjs = Nothing
  
End Sub