论坛 › VBA、COM-ActiveX › [原创]：一个选择集的增强类

雪山飞狐(lzh) 发表于 2004-11-18 22:40:09

[原创]：一个选择集的增强类

'TlsSel类
'By 雪山飞狐
'模块名---TlsSel
' You may use the code included in this module in any way,
' provided that both the above copyright notice and the
' release of liability (stated below) appear in all copies.
Private oSel As AcadSelectionSet
Private TlsFt, TlsFd
Private sName As String

Public Sub NullFilter()
'清空过滤器
    TlsFt = Null
    TlsFd = Null

End Sub

Private Function IsNull() As Boolean

    If oSel Is Nothing Then
      IsNull = True
    ElseIf oSel.Count = 0 Then
      IsNull = True
    Else
      IsNull = False
    End If
   
End Function

Public Sub Init(Optional ByVal Name As String = "TlsSel")
'创建选择集
On Error Resume Next
   
    NullFilter
    If Not oSel Is Nothing Then oSel.Delete
    sName = Name
    ThisDrawing.SelectionSets(sName).Delete
    Set oSel = ThisDrawing.SelectionSets.Add(sName)
   
End Sub

Private Sub Class_Terminate()
'类析构时清除选择集
On Error Resume Next
   
    If Not oSel Is Nothing Then oSel.Delete
   
End Sub

Public Function ToArray()
'转化选择集为对象数组输出
On Error Resume Next

    Dim i
    Dim objs() As AcadEntity
    Dim nCount As Integer
   
    nCount = oSel.Count - 1
    ReDim objs(nCount)
   
    For i = 0 To nCount
      Set objs(i) = oSel(i)
    Next i
   
    ToArray = objs
   
End Function

Public Property Get Count() As Integer
'获取选择集实体个数
On Error Resume Next

    Count = oSel.Count
   
End Property

Public Property Get Name() As String
'获取选择集名称
On Error Resume Next

    Name = sName
   
End Property


Public Property Get Item(ByVal Index) As AcadEntity
'获取选择集实体
On Error Resume Next

    Set Item = oSel(Index)
   
End Property

Public Sub Add(ByVal obj)
'向选择集加入单个实体
On Error Resume Next
   
    Dim objs(0) As AcadEntity
   
    Set objs(0) = obj
    oSel.AddItems pbjs
   
End Sub

Public Sub AddItems(ByVal objs)
'向选择集加入实体数组
On Error Resume Next
   
    oSel.AddItems objs
   
End Sub

Public Sub Remove(ByVal obj)
'在选择集中移除单个实体
On Error Resume Next
   
    Dim objs(0) As AcadEntity
    Set objs(0) = obj
    oSel.RemoveItems objs
   
End Sub


Public Sub RemoveItems(ByVal objs)
'在选择集中移除实体数组
On Error Resume Next
   
    oSel.RemoveItems objs
   
End Sub

Public Sub Clear()
'清空选择集
On Error Resume Next
   
    Select Case sName
    Case "PICKFIRST"
      GetPickfirstSel
    Case "CURRENT"
      GetActiveSel
    Case Else
      Init sName
    End Select
   
    oSel.Clear
   
End Sub

Public Sub Update()
On Error Resume Next
   
    oSel.Update

End Sub

Public Function GetSel() As AcadSelectionSet
'获取选择集
On Error Resume Next
   
    Set GetSel = oSel
   
End Function

Public Sub GetPickfirstSel()
'获取Pickfirst选择集
On Error Resume Next
      
    NullFilter
    If Not oSel Is Nothing Then oSel.Delete
    sName = "PICKFIRST"
    ThisDrawing.SelectionSets(sName).Delete
    Set oSel = ThisDrawing.PickfirstSelectionSet
   
End Sub

Public Sub GetActiveSel()
'获取Active选择集
On Error Resume Next
      
    NullFilter
    If Not oSel Is Nothing Then oSel.Delete
    sName = "CURRENT"
    ThisDrawing.SelectionSets(sName).Delete
    Set oSel = ThisDrawing.ActiveSelectionSet
   
End Sub

Public Sub SetFilterType(ParamArray FilterType())
'设置过滤器类型
On Error Resume Next
   
    Dim i
    Dim nCount As Integer
    nCount = UBound(FilterType)
   
    Dim ft() As Integer
    ReDim ft(nCount)
   
    For i = 0 To nCount
      ft(i) = FilterType(i)
    Next i
   
    TlsFt = ft
   
End Sub

Public Sub SetFilterData(ParamArray FilterData())
'设置过滤器数据
On Error Resume Next

    Dim i
    Dim nCount As Integer
    nCount = UBound(FilterData)
   
    Dim fd()
    ReDim fd(nCount)
   
    For i = 0 To nCount
      fd(i) = FilterData(i)
    Next i
   
    TlsFd = fd
   
End Sub

Public Sub SetFilter(ParamArray Filter())
'设置过滤器
On Error Resume Next
   
    Dim i
    Dim n As Integer
    Dim nCount As Integer
    nCount = (UBound(Filter) + 1) / 2 - 1
   
    Dim ft() As Integer, fd()
    ReDim ft(nCount), fd(nCount)
   
    For i = 0 To nCount
      n = i * 2
      ft(i) = Filter(n)
      fd(i) = Filter(n + 1)
    Next i
   
    TlsFt = ft
    TlsFd = fd

End Sub


Public Sub SelectObjectOnScreen()
On Error Resume Next
      
    If IsArray(TlsFt) Then
      oSel.SelectOnScreen TlsFt, TlsFd
    Else
      oSel.SelectOnScreen
    End If
   
End Sub

Public Sub Selectobject(ByVal Mode As AcSelect, Optional ByVal Point1, Optional ByVal Point2)
On Error Resume Next
      
    If IsArray(TlsFt) Then
      If IsMissing(Point1) Then
            oSel.Select Mode, , , TlsFt, TlsFd
      Else
            oSel.Select Mode, Point1, Point2, TlsFt, TlsFd
      End If
    Else
      If IsMissing(Point1) Then
            oSel.Select Mode
      Else
            oSel.Select Mode, Point1, Point2
      End If
    End If
   
End Sub

Public Sub SelectObjectAtPoint(ByVal Point)
On Error Resume Next
      
    If IsArray(TlsFt) Then
      oSel.SelectAtPoint Point, TlsFt, TlsFd
    Else
      oSel.SelectAtPoint Point
    End If
   
End Sub

Public Sub SelectObjectByPolygon(ByVal Mode As AcSelect, Optional ByVal Points, Optional ByVal Point2)
On Error Resume Next
      
    If IsArray(TlsFt) Then
      oSel.SelectByPolygon Mode, Points, TlsFt, TlsFd
    Else
      oSel.SelectByPolygon Mode, Points
    End If
   
End Sub

Public Property Let Visible(ByVal Value As Boolean)
On Error Resume Next

    If IsNull() Then Exit Property
   
    Dim i As AcadEntity
    For Each i In oSel
      i.Visible = Value
    Next i
   
End Property


Public Property Let Layer(ByVal Value As String)
On Error Resume Next

    If IsNull() Then Exit Property
   
    Dim i As AcadEntity
    For Each i In oSel
      i.Layer = Value
    Next i
   
End Property

Public Property Let LineType(ByVal Value As String)
On Error Resume Next

    If IsNull() Then Exit Property
   
    Dim i As AcadEntity
    For Each i In oSel
      i.LineType = Value
    Next i
   
End Property

Public Property Let Color(ByVal Value As ACAD_COLOR)
On Error Resume Next

    If IsNull() Then Exit Property
   
    Dim i As AcadEntity
    For Each i In oSel
      i.Color = Value
    Next i
   
End Property

Public Sub Move(Optional ByVal Point1, Optional ByVal Point2)
On Error Resume Next

    If IsNull() Then Exit Sub
    If IsMissing(Point1) Then Point1 = CreatePoint()
    If IsMissing(Point2) Then Point2 = CreatePoint()
   
    Dim i As AcadEntity
    For Each i In oSel
      i.Move Point1, Point2
    Next i
   
End Sub

Public Function Copy(Optional ByVal Point1, Optional ByVal Point2)
On Error Resume Next

    If IsNull() Then Exit Sub
    If IsMissing(Point1) Then Point1 = CreatePoint()
    If IsMissing(Point2) Then Point2 = CreatePoint()
   
    Dim objs() As AcadEntity
    Dim i
    ReDim objs(Count - 1)
   
    For i = 0 To Count
      Set objs(i) = oSel(i).Copy
      objs(i).Move Point1, Point2
    Next i
   
    Copy = objs
   
End Function

Public Sub Rotate(Optional ByVal BasePoint, Optional ByVal RotationAngle As Double = 1#)
On Error Resume Next

    If IsNull() Then Exit Sub
    If IsMissing(BasePoint) Then BasePoint = CreatePoint()
      
    Dim i As AcadEntity
    For Each i In oSel
      i.Rotate BasePoint, RotationAngle
    Next i

End Sub

Public Sub Rotate3D(Optional ByVal Point1, Optional ByVal Point2, Optional ByVal RotationAngle As Double = 1#)
On Error Resume Next

    If IsNull() Then Exit Sub
    If IsMissing(Point1) Then Point1 = CreatePoint()
    If IsMissing(Point2) Then Point2 = CreatePoint()
   
    Dim i As AcadEntity
    For Each i In oSel
      i.Rotate3D Point1, Point2, RotationAngle
    Next i

End Sub

Public Sub ScaleAll(Optional ByVal BasePoint, Optional ByVal scalefactor As Double = 1)
On Error Resume Next

    If IsNull() Then Exit Sub
    If IsMissing(BasePoint) Then BasePoint = CreatePoint()
   
    Dim i As AcadEntity
    For Each i In oSel
      i.ScaleEntity BasePoint, scalefactor
    Next i

End Sub

Public Sub Mirror(Optional ByVal Point1, Optional ByVal Point2)
On Error Resume Next

    If IsNull() Then Exit Sub
    If IsMissing(Point1) Then Point1 = CreatePoint()
    If IsMissing(Point2) Then Point2 = CreatePoint()
   
    Dim i As AcadEntity
    For Each i In oSel
      i.Mirror Point1, Point2
    Next i

End Sub

Public Sub Mirror3D(Optional ByVal Point1, Optional ByVal Point2, Optional ByVal Point3)
On Error Resume Next

    If IsNull() Then Exit Sub
    If IsMissing(Point1) Then Point1 = CreatePoint()
    If IsMissing(Point2) Then Point2 = CreatePoint()
    If IsMissing(Point3) Then Point3 = CreatePoint()
   
    Dim i As AcadEntity
    For Each i In oSel
      i.Mirror3D Point1, Point2, Point3
    Next i

End Sub

Public Sub Highlight(Optional ByVal HighlightFlag As Boolean = True)
On Error Resume Next
   
    Dim i As AcadEntity
    For Each i In oSel
      i.Highlight HighlightFlag
    Next i

End Sub

Public Sub Delete()
On Error Resume Next
   
    oSel.Erase

End Sub


Public Sub CopyObjects(Optional ByVal Owner, Optional ByVal IdPairs)
On Error Resume Next

    If IsNull() Then Exit Sub

    If IsMissing(Owner) Then
      If IsMissing(IdPairs) Then
            ThisDrawing.CopyObjects ToArray
      Else
            ThisDrawing.CopyObjects ToArray, , IdPairs
      End If
    Else
      If IsMissing(IdPairs) Then
            ThisDrawing.CopyObjects ToArray, Owner
      Else
            ThisDrawing.CopyObjects ToArray, Owner, IdPairs
      End If
    End If

End Sub

Public Sub GetBoundingBox(ByRef MinPoint, ByRef MaxPoint)
On Error Resume Next

    Dim i
    Dim d1, d2, p1, p2
   
    If IsNull() Then Exit Sub
   
    oSel(0).GetBoundingBox d1, d2
   
    For i = 1 To Count - 1
   
      oSel(i).GetBoundingBox p1, p2
      
      If p1(0) < d1(0) Then d1(0) = p1(0)
      If p1(1) < d1(1) Then d1(1) = p1(1)
      If p2(0) > d2(0) Then d2(0) = p2(0)
      If p2(1) > d2(1) Then d2(1) = p2(1)
      
    Next i
   
    MinPoint = d1
    MaxPoint = d2
   
End Sub

Public Function ToBlock(Optional ByVal InsertionPoint, Optional ByVal Name As String = "*U") As String
On Error GoTo ErrHandle

    If IsNull() Then Exit Function
    If IsMissing(InsertionPoint) Then InsertionPoint = CreatePoint()
   
    Dim oBlock As AcadBlock
    Set oBlock = ThisDrawing.Blocks.Add(InsertionPoint, Name)
    CopyObjects oBlock
   
    ToBlock = oBlock.Name
   
ErrHandle:

End Function

Function CreateArray(ByVal TypeName As VbVarType, ParamArray ValArray())
    Dim nCount As Integer
    Dim i
    Dim mArray
   
    nCount = UBound(ValArray)
   
    Select Case TypeName
    Case vbDouble
      Dim dArray() As Double
      ReDim dArray(nCount)
      mArray = dArray
    Case vbInteger
      Dim nArray() As Integer
      ReDim nArray(nCount)
      mArray = nArray
    Case vbString
      Dim sArray() As String
      ReDim sArray(nCount)
      mArray = sArray
    Case vbVariant
      Dim vArray()
      ReDim vArray(nCount)
      mArray = vArray
    End Select
   
    For i = 0 To nCount
      mArray(i) = ValArray(i)
    Next i
   
    CreateArray = mArray
End Function

Public Function CreatePoint(Optional ByVal X As Double = 0#, Optional ByVal Y As Double = 0#, Optional ByVal Z As Double = 0#)
   
    Dim pnt(2) As Double
    pnt(0) = X: pnt(1) = Y: pnt(2) = Z
   
    CreatePoint = pnt
   
End Function

雪山飞狐(lzh) 发表于 2004-11-18 22:43:00

下面是一段测试

Sub test()
    Dim ss As New TlsSel
    ss.Init
    ss.SetFilter 0, "Insert", 2, "1"
    ss.Selectobject acSelectionSetAll
    MsgBox ss.Count
End Sub

pckite 发表于 2004-11-19 08:59:05

很好的一个类！请问引用块的过滤数据类型和数据是什么？谢谢

Public Sub SetFilter(ParamArray Filter())
'设置过滤器
On Error Resume Next
   
    Dim i
    Dim n As Integer
    Dim nCount As Integer
    nCount = (UBound(Filter) + 1) / 2 - 1
   
    Dim ft() As Integer, fd()
    ReDim ft(nCount), fd(nCount)
   
    For i = 0 To nCount
      n = i * 2
      ft(i) = Filter(n)
      fd(i) = Filter(n + 1)
    Next i
   
    TlsFt = ft
    TlsFd = fd

End Sub
这个函数不太明白，为什么nCount = (UBound(Filter) + 1) / 2 - 1？？

雪山飞狐(lzh) 发表于 2004-11-19 09:36:27

(UBound(Filter) + 1)是Filter数组的元素个数
设置过滤器前先在命令行键入"(entget(car(entsel)))"，看看对应实体的DXF组码

自由的鱼 发表于 2004-11-20 00:56:56

好程序！！怎么没有加分？

qinchao_qc 发表于 2005-3-18 20:02:50

类是不是就是一种数据类型，自定义的？

misters 发表于 2005-6-7 18:41:30

doc1.CopyObjects ToArray(acadselect)


Public Function ToArray(ByVal osel As AcadSelectionSet)
'转化选择集为对象数组输出
On Error Resume Next

    Dim i
    Dim objs() As AcadEntity
    Dim nCount As Integer

    nCount = osel.Count - 1
    ReDim objs(nCount)

    For i = 0 To nCount
      Set objs(i) = osel(i)
    Next i

    ToArray = objs
End Function

toarry拿出来放到其它的程序中调用时，执行到toarry=objs时就出错，提示“对象不在数据库中”是怎么回事？

keita027 发表于 2009-3-7 11:10:15

ddddddddddddd

modernyoung 发表于 2009-7-24 16:50:21

好顶一个

查看完整版本: [原创]：一个选择集的增强类