mdllistview.bas

<Visual Basic 数据库开发实例精粹（第二版）>一书首先介绍了Visual Basic(简称VB)开发的技巧和重点技术

Attribute VB_Name = "mdlListView"
Option Explicit

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

'将单个客户加入列表，或在列表中更新
'特意将该函数单独做出来，而没有将本函数中的代码完全在ClientsToListview函数中实现
'Why?
'因为在设计该功能时，你还应考虑到在以后的编程过程中，很可能要用到
'将某个单独的“客户”对象加入列表框（比如新增加了一个客户）。
Public Sub AddClientToLvw(ByVal objClient As CClient, _
                          ByRef lvw As ListView, _
                          ByVal IsOverWrite As Boolean)
  '第三个参数如果是TRUE，则说明是更新当前已存在的某个列表项，否则是新加一个列表项
  Dim Itm As ListItem
  Dim sIcon As String
  Dim bIcon As String
  
  '根据性别不同来选取不同的头像
  If objClient.Sex = Male Then
    sIcon = "sboy"
    bIcon = "bboy"
  Else
    sIcon = "sgirl"
    bIcon = "bgirl"
  End If
  
  '如果是更新（即覆盖），则使用当前选种的元素
  If IsOverWrite Then
    Set Itm = lvw.SelectedItem
    If Itm Is Nothing Then Exit Sub
  Else
    Set Itm = lvw.ListItems.Add(, "A" & objClient.ID, , bIcon, sIcon)
  End If
  With objClient  '这里要与InitClientListview相对应
    Itm.SmallIcon = sIcon
    Itm.Icon = bIcon
    Itm.Text = .Name
    Itm.SubItems(1) = .TypeName
    Itm.SubItems(2) = IIf(.Sex = Male, "男", "女")
    Itm.SubItems(3) = .Mobile
    Itm.SubItems(4) = .Email
    Itm.SubItems(5) = IIf(.BirthdayWarn, "启用", "未启用")
  End With
  Set Itm = Nothing
End Sub


'按照“客户”设置ListView的显示样式
Public Sub InitClientListview(ByRef lvw As ListView)
  With lvw
    .ColumnHeaders.Clear
    '加入四个列首
    .ColumnHeaders.Add , , "姓名", 1200
    .ColumnHeaders.Add , , "客户类别", 1500
    .ColumnHeaders.Add , , "性别", 500
    .ColumnHeaders.Add , , "手机", 1300
    .ColumnHeaders.Add , , "E-mail", 1500
    .ColumnHeaders.Add , , "生日提醒", 1000
  End With
End Sub

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

' 显示全部客户到列表控件
Public Sub ListAllClients(ByRef lvw As ListView)
  Dim objClients As New CClients
  Dim rstClients As CClients
  
  'Find的两个参数均取默认值，此时查找全部的客户
  Set rstClients = objClients.Find
  
  '将查找到的客户集合添加到列表控件中
  ClientsToListview rstClients, lvw
  
  Set objClients = Nothing
  Set rstClients = Nothing
  
End Sub


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

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

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


Public Sub ClientsToCombo(ByVal objTypes As CTypes, ByRef cbo As ComboBox)
  '传入参数为客户的集合类与列表框
  Dim i As Long
  
  cbo.Clear '清除当前的列表内容
  
  For i = 1 To objTypes.Count
    '将每个“客户”都加入到该列表中，调用了单独的函数，没有全部做到这
    '个函数中，为什么呢？参看AddClientToLvw函数
    Call cbo.AddItem(objTypes.Item(i).TypeName, i - 1)
    cbo.ItemData(i - 1) = objTypes.Item(i).ID
  Next i
  
End Sub

Public Sub AllClientsTypeToCombo(ByRef cbo As ComboBox)
  Dim objTypes As New CTypes
  Dim rstTypes As CTypes
  
  Set rstTypes = objTypes.Find
  ClientsToCombo objTypes, cbo
  
  Set objTypes = Nothing
  Set rstTypes = Nothing
  
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'与Warning相关的操作
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'按照“客户”设置ListView的显示样式
Public Sub InitWarnListview(ByRef lvw As ListView)
  With lvw
    .ColumnHeaders.Clear
    '加入四个列首
    .ColumnHeaders.Add , , "提醒客户", 1000
    .ColumnHeaders.Add , , "显示时间", 1000
    .ColumnHeaders.Add , , "提醒类型", 1000
    .ColumnHeaders.Add , , "提醒内容", 5000
  End With
End Sub

Public Sub AddWarnToLvw(ByVal objWarn As cWarning, ByRef lvw As ListView, ByVal IsOverWrite As Boolean)
  '第三个参数如果是TRUE，则说明是更新当前已存在的某个列表项，否则是新加一个列表项
  Dim Itm As ListItem
  Dim sIcon As String
  Dim bIcon As String
  
  If objWarn.ID = Male Then
    sIcon = "sboy"
    bIcon = "bboy"
  Else
    sIcon = "sgirl"
    bIcon = "bgirl"
  End If
  
  If IsOverWrite Then
    Set Itm = lvw.SelectedItem
    If Itm Is Nothing Then Exit Sub
  Else
    Set Itm = lvw.ListItems.Add(, "W" & objWarn.ID)
  End If
  With objWarn
    Itm.Text = .ClientName
    Itm.SubItems(1) = .ShowDate
    Itm.SubItems(2) = .TypeName
    Itm.SubItems(3) = .Msg
  End With
  Set Itm = Nothing
End Sub

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

Public Sub ListAllWarnings(ByRef lvw As ListView)
  Dim objWarnings As New CWarnings
  Dim rstWarnings As CWarnings
  
  Set rstWarnings = objWarnings.Find
  WarningsToListview rstWarnings, lvw
  
  Set objWarnings = Nothing
  Set rstWarnings = Nothing
  
End Sub


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

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

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

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 与合作记录相关的列表操作
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'按照“客户”设置ListView的显示样式
Public Sub InitCooperateListview(ByRef lvw As ListView)
  With lvw
    .ColumnHeaders.Clear
    '加入四个列首
    .ColumnHeaders.Add , , "合作客户", 1000
    .ColumnHeaders.Add , , "合作时间", 1000
    .ColumnHeaders.Add , , "满意度", 1000
    .ColumnHeaders.Add , , "合作说明", 5000
  End With
End Sub

Public Sub AddCooperateToLvw(ByVal objCoop As CCooperate, ByRef lvw As ListView, ByVal IsOverWrite As Boolean)
  '第三个参数如果是TRUE，则说明是更新当前已存在的某个列表项，否则是新加一个列表项
  Dim Itm As ListItem
  
  If IsOverWrite Then
    Set Itm = lvw.SelectedItem
    If Itm Is Nothing Then Exit Sub
  Else
    Set Itm = lvw.ListItems.Add(, "W" & objCoop.ID)
  End If
  With objCoop
    Itm.Text = .ClientName
    Itm.SubItems(1) = .CooperateDate
    Itm.SubItems(2) = .Satisfaction
    Itm.SubItems(3) = .Remark
  End With
  Set Itm = Nothing
End Sub

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

Public Sub ListAllCooperates(ByRef lvw As ListView, Optional ByVal lngClientId As Long = 0)
  Dim objCooperates As New CCooperates
  Dim rstCooperates As CCooperates
  
  Set rstCooperates = objCooperates.Find(, lngClientId)
  CooperatesToListview rstCooperates, lvw
  
  Set objCooperates = Nothing
  Set rstCooperates = Nothing
  
End Sub


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

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

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