clsopimage.cls

利用ＶＢ和ＡＣＥＳＳ联合制作的一个人事和物品管理系统

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsOpImage"
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
Dim fso As New FileSystemObject

Dim sNam As String
  Dim ssNam As String
  Dim sFor As String



'==============================================================
'
' 处理增、删、改
'
'===============================================================
'管理增加操作
Public Sub Add(ctl As Object, nTypeID As Long)
  Dim obj As clsImage
  Dim Result As gxcAddNew
  
  If nTypeID = 0 Then
    MsgBox "请选择图像类型"
    Exit Sub
  End If
  '显示添商品对话框并获取数据
  If Not frmImage.ShowDlg(obj, vtadd, nTypeID) Then Exit Sub
  '更新数据库
  Result = obj.AddNew
  If Result = AddNewOK Then
    AddToLvw obj, ctl, False
    If fso.FileExists(frmImage.path) = True Then
   
      Call fso.CopyFile(frmImage.path, frmImage.sDirectory, True)
    End If
  ElseIf Result = DuplicateName_AddNew Then
    MsgBox "名称重复"
  Else
    MsgBox "错误"
  End If

End Sub

'管理修改操作
Public Sub Modify(ctl As Object)
  Dim obj As clsImage
  Dim strName As String
  
  '获取列表框选中的图像，如果没有选中的对象则退出函数
  If GetObjFromControl(ctl, obj) = False Then
    MsgBox "请选择图像类型"
    Exit Sub
  End If
  
  '显示添加客户对话框并获取数据
  If Not frmImage.ShowDlg(obj, vtModify) Then Exit Sub
  '更新数据库
  Dim Result As gxcUpdate
  Result = obj.Update
  If Result = UpdateOK Then
    '将图像在更表框中更新
    If fso.FileExists(App.path & "\图像" & "\" & sNam & "\" & ssNam) = True Then
     Call fso.CopyFile(App.path & "\图像" & "\" & sNam & "\" & ssNam, App.path & "\图像" & "\" & frmImage.sDir & "\" & frmImage.sIName, True)
     Call fso.DeleteFile(App.path & "\图像" & "\" & sNam & "\" & ssNam)
    End If
    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 clsImage
  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
    '来到这，说明删除成功，从树形图中删除节点
    
    
    If fso.FileExists(App.path & "\图像" & "\" & sNam & "\" & ssNam) = True Then
     Call fso.DeleteFile(App.path & "\图像" & "\" & sNam & "\" & ssNam)
    End If
    ctl.ListItems.Remove ctl.SelectedItem.Index
  End If
End Sub


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

'将单个对象加入列表，或在列表中更新
Public Sub AddToLvw(ByVal obj As clsImage, _
                          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  '这里要与InitListview相对应
    
    Itm.Icon = bIcon
    
  
    Itm.SmallIcon = sIcon
   Itm.Text = .IName
    Itm.SubItems(1) = .TypeName
            Itm.SubItems(2) = .Res
            Itm.SubItems(3) = .Proj
            Itm.SubItems(4) = CStr(.IDate)
            Itm.SubItems(5) = .IFormat
            Itm.SubItems(6) = CStr(.MinX)
            Itm.SubItems(7) = CStr(.MaxX)
            Itm.SubItems(8) = CStr(.MinY)
            Itm.SubItems(9) = CStr(.MaxY)
            Itm.SubItems(10) = .Introduce
            Itm.SubItems(11) = .Label
           
  End With
  Set Itm = Nothing
End Sub

'设置LISTVIEW的显示样式
Public Sub InitListview(ByRef lvw As Object)
 With lvw
  .ColumnHeaders.Clear
  '加入列首
  .ColumnHeaders.Add , , "名称", 1200
  .ColumnHeaders.Add , , "类别", 1500
  .ColumnHeaders.Add , , "分辨率", 1200
  .ColumnHeaders.Add , , "投影", 1300
  .ColumnHeaders.Add , , "日期", 1000
  .ColumnHeaders.Add , , "格式", 1000
  .ColumnHeaders.Add , , "最小X", 800
  .ColumnHeaders.Add , , "最大X", 800
  .ColumnHeaders.Add , , "最小Y", 800
  .ColumnHeaders.Add , , "最大Y", 800
  .ColumnHeaders.Add , , "介绍", 1500
  .ColumnHeaders.Add , , "标签", 1200
 End With
End Sub

'将对象集合显示到ListView中
Public Sub ObjsToListView(ByVal objs As clsImages, ByRef lvw As Object)
  '传入参数为商品的集合类与列表框
  Dim i As Long
  '如果列表还未初始化，则初始化之
  If lvw.ColumnHeaders.Count < 12 Then InitListview lvw
  lvw.ListItems.Clear '清除当前的列表内容
  
  For i = 1 To objs.Count
    '将每个“图像”都加入到该列表中，调用了单独的函数，
    AddToLvw 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 clsImages
  Dim rstObjs As clsImages
  
  '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 Function GetObjFromControl(ByVal lvw As Object, _
                                    ByRef obj As clsImage) As Boolean
  '如果列表中没有被选择的项，则直接退出
  If lvw.SelectedItem Is Nothing Then
    GetObjFromControl = False
    Exit Function
  End If

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

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




'==============================================================
'
' 处理Combo控件：FillCombo，ObjsToCombo
'
'===============================================================

'传入参数为对象的集合类与组合框
Private Sub ObjsToCombo(ByVal objs As clsImages, ByRef cbo As ComboBox)
  Dim i As Long
  
  cbo.Clear '清除当前的列表内容
  
  For i = 1 To objs.Count
    Call cbo.AddItem(objs.Item(i).IName, i - 1)
    cbo.ItemData(i - 1) = objs.Item(i).ID
  Next i
  
End Sub

'将数据库中全部对象加入到组合框中
Public Sub FillCombo(ByRef cbo As Object)
  Dim objs As New clsImages
  Dim rstObjs As clsImages
  
  Set rstObjs = objs.Find
  ObjsToCombo rstObjs, cbo
  
  Set objs = Nothing
  Set rstObjs = Nothing
  
End Sub