CAD

开发平台：
VBA

TlsSelectionSet.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 = "TlsSelectionSet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Private m_oSel As AcadSelectionSet
Private m_vFilterType, m_vFilterData
Private m_sName As String
Private m_oApp As AcadApplication
Private m_oUtility As New TlsUtility
Public Property Let Application(ByVal vNewValue As AcadApplication)
    Set m_oApp = vNewValue
End Property
Private Property Get ThisDrawing() As AcadDocument
    Set ThisDrawing = m_oApp.ActiveDocument
End Property
Public Sub NullFilter()
'清空过滤器
    m_vFilterType = Null
    m_vFilterData = Null
End Sub
Private Function IsNull() As Boolean
    If m_oSel Is Nothing Then
        IsNull = True
    ElseIf m_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 m_oSel Is Nothing Then m_oSel.Delete
    m_sName = Name
    ThisDrawing.SelectionSets(m_sName).Delete
    Set m_oSel = ThisDrawing.SelectionSets.Add(m_sName)
    
End Sub
Private Sub Class_Terminate()
'类析构时清除选择集
On Error Resume Next
    
    If Not m_oSel Is Nothing Then m_oSel.Delete
    
End Sub
Public Property Get Count() As Integer
'获取选择集实体个数
On Error Resume Next
    Count = m_oSel.Count
    
End Property
Public Property Get Name() As String
'获取选择集名称
On Error Resume Next
    Name = m_sName
    
End Property
Public Property Get Item(ByVal Index) As AcadEntity
Attribute Item.VB_UserMemId = 0
'获取选择集实体
On Error Resume Next
    Set Item = m_oSel(Index)
    
End Property
Public Sub Add(ByVal obj)
'向选择集加入单个实体
On Error Resume Next
    
    Dim objs(0) As AcadEntity
    
    Set objs(0) = obj
    m_oSel.AddItems objs
    
End Sub
Public Sub AddItems(ByVal objs)
'向选择集加入实体数组
On Error Resume Next
    
    m_oSel.AddItems objs
    
End Sub
Public Sub Remove(ByVal obj)
'在选择集中移除单个实体
On Error Resume Next
    
    Dim objs(0) As AcadEntity
    Set objs(0) = obj
    m_oSel.RemoveItems objs
    
End Sub
Public Sub RemoveItems(ByVal objs)
'在选择集中移除实体数组
On Error Resume Next
    
    m_oSel.RemoveItems objs
    
End Sub
Public Sub Clear()
'清空选择集
On Error Resume Next
    
    Select Case m_sName
    Case "PICKFIRST"
        GetPickfirstSelectionSet
    Case "CURRENT"
        GetActiveSelectionSet
    Case Else
        Init m_sName
    End Select
    
    m_oSel.Clear
    
End Sub
Public Sub Update()
On Error Resume Next
    
    m_oSel.Update
End Sub
Public Sub GetPickfirstSelectionSet()
'获取Pickfirst选择集
On Error Resume Next
        
    NullFilter
    If Not m_oSel Is Nothing Then m_oSel.Delete
    m_sName = "PICKFIRST"
    ThisDrawing.SelectionSets(m_sName).Delete
    Set m_oSel = ThisDrawing.PickfirstSelectionSet
    
End Sub
Public Sub GetActiveSelectionSet()
'获取Active选择集
On Error Resume Next
        
    NullFilter
    If Not m_oSel Is Nothing Then m_oSel.Delete
    m_sName = "CURRENT"
    ThisDrawing.SelectionSets(m_sName).Delete
    Set m_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
    
    m_vFilterType = 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
    
    m_vFilterData = 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
    
    m_vFilterType = ft
    m_vFilterData = fd
End Sub
Public Sub SelectObjectOnScreen()
On Error Resume Next
        
    If IsArray(m_vFilterType) Then
        m_oSel.SelectOnScreen m_vFilterType, m_vFilterData
    Else
        m_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(m_vFilterType) Then
        If IsMissing(Point1) Then
            m_oSel.Select Mode, , , m_vFilterType, m_vFilterData
        Else
            m_oSel.Select Mode, Point1, Point2, m_vFilterType, m_vFilterData
        End If
    Else
        If IsMissing(Point1) Then
            m_oSel.Select Mode
        Else
            m_oSel.Select Mode, Point1, Point2
        End If
    End If
    
End Sub
Public Sub SelectObjectAtPoint(ByVal Point)
On Error Resume Next
        
    If IsArray(m_vFilterType) Then
        m_oSel.SelectAtPoint Point, m_vFilterType, m_vFilterData
    Else
        m_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(m_vFilterType) Then
        m_oSel.SelectByPolygon Mode, Points, m_vFilterType, m_vFilterData
    Else
        m_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 m_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 m_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 m_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 m_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 = m_oUtility.CreatePoint()
    If IsMissing(Point2) Then Point2 = m_oUtility.CreatePoint()
    
    Dim i As AcadEntity
    For Each i In m_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 Function
    If IsMissing(Point1) Then Point1 = m_oUtility.CreatePoint()
    If IsMissing(Point2) Then Point2 = m_oUtility.CreatePoint()
    
    Dim objs() As AcadEntity
    Dim i
    ReDim objs(Count - 1)
    
    For i = 0 To Count
        Set objs(i) = m_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 = m_oUtility.CreatePoint()
        
    Dim i As AcadEntity
    For Each i In m_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 = m_oUtility.CreatePoint()
    If IsMissing(Point2) Then Point2 = m_oUtility.CreatePoint()
    
    Dim i As AcadEntity
    For Each i In m_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 = m_oUtility.CreatePoint()
    
    Dim i As AcadEntity
    For Each i In m_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 = m_oUtility.CreatePoint()
    If IsMissing(Point2) Then Point2 = m_oUtility.CreatePoint()
    
    Dim i As AcadEntity
    For Each i In m_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 = m_oUtility.CreatePoint()
    If IsMissing(Point2) Then Point2 = m_oUtility.CreatePoint()
    If IsMissing(Point3) Then Point3 = m_oUtility.CreatePoint()
    
    Dim i As AcadEntity
    For Each i In m_oSel
        i.Mirror3D Point1, Point2, Point3
    Next i
End Sub
Public Function Highlight(Optional ByVal HighlightFlag As Boolean = True) As Boolean
On Error Resume Next
    
    Dim i As AcadEntity
    For Each i In m_oSel
        i.Highlight HighlightFlag
    Next i
    If Err Then Highlight = False Else Highlight = True
    
End Function
Public Function Delete() As Boolean
On Error Resume Next
    
    m_oSel.Erase
    If Err Then Delete = False Else Delete = True
End Function
Public Function CopyObjects(Optional ByVal Owner, Optional ByVal IdPairs) As Boolean
On Error Resume Next
    If IsNull() Then Exit Function
    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
    
    If Err Then CopyObjects = False Else CopyObjects = True
End Function
Public Function GetBoundingBox(ByRef MinPoint, ByRef MaxPoint) As Boolean
On Error Resume Next
    Dim i
    Dim d1, d2, p1, p2
    
    If IsNull() Then Exit Function
    
    m_oSel(0).GetBoundingBox d1, d2
    
    For i = 1 To Count - 1
    
        m_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
    If Err Then GetBoundingBox = False Else GetBoundingBox = True
    
End Function
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 = m_oUtility.CreatePoint()
    
    Dim oBlock As AcadBlock
    Set oBlock = ThisDrawing.Blocks.Add(InsertionPoint, Name)
    CopyObjects oBlock
    
    ToBlock = oBlock.Name
    
ErrHandle:
End Function
Public Function ToSelectionSet() As AcadSelectionSet
'获取选择集
On Error Resume Next
    
    Set ToSelectionSet = m_oSel
    
End Function
Public Function ToArray()
'转化选择集为对象数组输出
On Error Resume Next
  
    Dim i
    Dim objs() As AcadEntity
    Dim nCount As Integer
    
    nCount = m_oSel.Count - 1
    ReDim objs(nCount)
    
    For i = 0 To nCount
        Set objs(i) = m_oSel(i)
    Next i
    
    ToArray = objs
    
End Function
Public Function GetEntity() As Object
On Error Resume Next
    Dim bJudge As Boolean
    Dim pnt
    
    bJudge = False
    
    Do While Not bJudge
        ThisDrawing.Utility.GetEntity GetEntity, pnt
        m_oSel.Select acSelectionSetAll, , , m_vFilterType, m_vFilterData
        For Each i In m_oSel
            If i Is GetEntity Then
                bJudge = True
                Exit Do
            End If
        Next i
    Loop
End Function

						