[转贴]：VBA_选择集增强类(TlsSelectionSet)

netbee

[PHP]Private oSel As AcadSelectionSet
Private m_Filter As New TlsResultBuffer
Private sName As String
Private bDeleted As Boolean

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 = "TlsSelectionSet", Optional ClearFilter As Boolean = True, Optional Deleted As Boolean = True)
'创建选择集
On Error Resume Next

If ClearFilter Then m_Filter.Clear
bDeleted = Deleted
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 bDeleted 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 Property Get Deleted() As Boolean
Deleted = bDeleted
End Property

Public Property Let Deleted(ByVal Value As Boolean)
bDeleted = Value
End Property

Public Property Get AcSet() As Variant
'获取选择集
On Error Resume Next

Set AcSet = oSel

End Property

Public Property Set AcSet(Value As Variant)
'获取选择集
On Error Resume Next

Set oSel = Value

End Property


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

If IsArray(objs) Then
oSel.AddItems objs
ElseIf IsObject(objs) Then
If TypeOf objs Is AcadSelectionSet Then
Dim temp As New TlsSelectionSet
temp.Deleted = False
temp.AcSet = objs
oSel.AddItems temp.ToArray
ElseIf TypeOf objs Is TlsSelectionSet Then
oSel.AddItems objs.ToArray
Else
Dim ents(0) As AcadEntity
Set ents(0) = objs
oSel.AddItems ents
End If
End If

End Sub

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

If IsArray(objs) Then
oSel.RemoveItems objs
ElseIf IsObject(objs) Then
If TypeOf objs Is AcadSelectionSet Then
Dim temp As New TlsSelectionSet
temp.Deleted = False
temp.AcSet = objs
oSel.RemoveItems temp.ToArray
ElseIf TypeOf objs Is TlsSelectionSet Then
oSel.RemoveItems objs.ToArray
Else
Dim ents(0) As AcadEntity
Set ents(0) = objs
oSel.RemoveItems ents
End If
End If

End Sub

Public Sub Clear()
'清空选择集
On Error Resume Next

Init sName
oSel.Clear

End Sub

Public Sub Update()
On Error Resume Next

oSel.Update

End Sub


Public Property Get PickfirstSelectionSet() As AcadSelectionSet
'获取Pickfirst选择集
On Error Resume Next

ThisDrawing.SelectionSets("PICKFIRST").Delete
Set PickfirstSelectionSet = ThisDrawing.PickfirstSelectionSet

End Property

Public Property Get ActiveSelectionSet() As AcadSelectionSet
'获取Active选择集
On Error Resume Next

ThisDrawing.SelectionSets("CURRENT").Delete
Set ActiveSelectionSet = ThisDrawing.ActiveSelectionSet

End Property

Public Sub SelectOnScreen()
On Error Resume Next

If m_Filter.IsNull Then
oSel.SelectOnScreen
Else
oSel.SelectOnScreen m_Filter.TypeCodes, m_Filter.Datas
End If

End Sub

Public Sub SelectSingleObject()
On Error GoTo ErrHandle
Dim obj As AcadEntity, pnt
SelectObject acSelectionSetAll
Do
ThisDrawing.Utility.GetEntity obj, pnt
oCount = Count
RemoveItems obj
If oCount <> Count Then
Clear
AddItems obj
Exit Do
End If
Loop
Exit Sub
ErrHandle:
Clear
End Sub

Public Sub SelectObject(ByVal Mode As AcSelect, Optional ByVal Point1, Optional ByVal Point2)
On Error Resume Next

If m_Filter.IsNull Then
If IsMissing(Point1) Then
oSel.Select Mode
Else
oSel.Select Mode, Point1, Point2
End If
Else
If IsMissing(Point1) Then
oSel.Select Mode, , , m_Filter.TypeCodes, m_Filter.Datas
Else
oSel.Select Mode, Point1, Point2, m_Filter.TypeCodes, m_Filter.Datas
End If
End If

End Sub

Public Sub SelectAtPoint(ByVal Point)
On Error Resume Next

If m_Filter.IsNull Then
oSel.SelectAtPoint Point
Else
oSel.SelectAtPoint Point, m_Filter.TypeCodes, m_Filter.Datas
End If

End Sub

Public Sub SelectByPolygon(ByVal Mode As AcSelect, Optional ByVal Points)
On Error Resume Next

If m_Filter.IsNull Then
oSel.SelectByPolygon Mode, Points
Else
oSel.SelectByPolygon Mode, Points, m_Filter.TypeCodes, m_Filter.Datas
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 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

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

If IsMissing(InsertionPoint) Then InsertionPoint = CreatePoint()

If IsNull() Then Exit Function

Dim oBlock As AcadBlock
Set oBlock = ThisDrawing.Blocks.Add(InsertionPoint, Name)
CopyObjects oBlock

ToBlock = oBlock.Name

ErrHandle:

End Function

Public Property Get Filter() As TlsResultBuffer
On Error Resume Next

Set Filter = m_Filter

If Err Then
Set m_Filter = New TlsResultBuffer
Set Filter = m_Filter
Err.Clear
End If

End Property
[/PHP]