一个选择集的增强类，刚写好，大家提提意见

雪山飞狐_lzh · 发表于 2006-3-18 15:21:00

本帖最后由作者于 2006-3-19 13:28:58 编辑

2006-3-18改进版
1、将过滤器单独作为一个类
2、去掉SetFilterType，SetFilerData两个多余的方法
3、增加AppendData方法
具体看：
http://www1.139.com/xsfhlzh/1025501/Article/325507.html
http://www1.139.com/xsfhlzh/1025501/Article/332841.html
测试例程（选择线型为ACAD_ISO04W100或ACAD_ISO10W100的实体）

Sub test()
Dim ss As New TlsSel
Dim i As AcadLayer
zxxNames = "ACAD_ISO04W100,ACAD_ISO10W100"
ss.Init
ss.Filter.SetData -4, "<or", 6, zxxNames
For Each i In ThisDrawing.Layers
If InStr(zxxNames, i.LineType) <> 0 Then
ss.Filter.AppendData -4, "<and", 8, i.Name, 6, "bylayer", -4, "and>"
End If
Next
ss.Filter.AppendData -4, "or>"
ss.Selectobject acSelectionSetAll
MsgBox ss.Count
End Sub

zhu1 · 发表于 2006-3-19 10:51:00

好东西

方便多了

雪山飞狐_lzh · 发表于 2009-4-3 22:46:00

本帖最后由作者于 2009-4-4 15:18:45 编辑

又把老帖子翻出来了，很早以前写过的，陆陆续续改过n回，哈
把最新版本还是贴上来吧

'ClassName:TlsResultBuffer
'Writer:xsfhlzh
'用于选择集过滤器、扩展数据及字典
Private m_TypeCodes, m_Datas
Private m_Count As Integer
Public Sub SetData(ParamArray Values())
On Error Resume Next
Dim i
Dim n As Integer
Dim nCount As Integer
nCount = (UBound(Values) + 1) / 2 - 1
If nCount = 0 And IsArray(Values(0)) And IsArray(Values(1)) Then
m_TypeCodes = Values(0)
m_Datas = Values(1)
Else
Dim t() As Integer, d()
ReDim t(nCount), d(nCount)
For i = 0 To nCount
n = i * 2
t(i) = Values(n)
d(i) = Values(n + 1)
Next i
m_TypeCodes = t
m_Datas = d
End If
m_Count = UBound(m_TypeCodes) + 1
End Sub
Public Sub AppendData(ParamArray Values())
On Error Resume Next
Dim m As Integer, n As Integer, nCount As Integer
nCount = (UBound(Values) + 1) / 2
n = m_Count + nCount - 1
ReDim Preserve m_TypeCodes(n), m_Datas(n)
For i = 0 To nCount - 1
m = m_Count + i
n = i * 2
m_TypeCodes(m) = Values(n)
m_Datas(m) = Values(n + 1)
Next i
m_Count = m_Count + nCount
End Sub
Public Sub GetData(ByRef TypeCodes, ByRef Datas)
TypeCodes = m_TypeCodes
Datas = m_Datas
End Sub
Public Sub Clear()
m_TypeCodes = Null
m_Datas = Null
End Sub
Public Property Get TypeCodes() As Variant
TypeCodes = m_TypeCodes
End Property
Public Property Let TypeCodes(ByVal vNewValue As Variant)
m_TypeCodes = vNewValue
End Property
Public Property Get Datas() As Variant
Datas = m_Datas
End Property
Public Property Let Datas(ByVal vNewValue As Variant)
m_Datas = vNewValue
End Property
Public Property Get Count() As Integer
On Error Resume Next
Count = m_Count
End Property
Public Property Get IsNull() As Boolean
IsNull = (Count = 0)
End Property

'ClassName:TlsResultBuffer
'Writer:xsfhlzh
'用于选择集过滤器、扩展数据及字典
Private m_TypeCodes, m_Datas
Private m_Count As Integer
Public Sub SetData(ParamArray Values())
On Error Resume Next
    
     Dim i
     Dim n As Integer
     Dim nCount As Integer
     nCount = (UBound(Values) + 1) / 2 - 1
    
     If nCount = 0 And IsArray(Values(0)) And IsArray(Values(1)) Then
    
        m_TypeCodes = Values(0)
        m_Datas = Values(1)
    
     Else
    
        Dim t() As Integer, d()
        ReDim t(nCount), d(nCount)
        For i = 0 To nCount
            n = i * 2
            t(i) = Values(n)
            d(i) = Values(n + 1)
        Next i
    
        m_TypeCodes = t
        m_Datas = d
    
    End If
    m_Count = UBound(m_TypeCodes) + 1
End Sub
Public Sub AppendData(ParamArray Values())
On Error Resume Next
    Dim m As Integer, n As Integer, nCount As Integer
    nCount = (UBound(Values) + 1) / 2
    n = m_Count + nCount - 1
    ReDim Preserve m_TypeCodes(n), m_Datas(n)
    For i = 0 To nCount - 1
        m = m_Count + i
        n = i * 2
        m_TypeCodes(m) = Values(n)
        m_Datas(m) = Values(n + 1)
    Next i
    m_Count = m_Count + nCount
    
End Sub
Public Sub GetData(ByRef TypeCodes, ByRef Datas)
    TypeCodes = m_TypeCodes
    Datas = m_Datas
End Sub
Public Sub Clear()
    m_TypeCodes = Null
    m_Datas = Null
    
End Sub
Public Property Get TypeCodes() As Variant
    TypeCodes = m_TypeCodes
 
End Property
Public Property Let TypeCodes(ByVal vNewValue As Variant)
    m_TypeCodes = vNewValue
 
End Property
Public Property Get Datas() As Variant
    Datas = m_Datas
    
End Property
Public Property Let Datas(ByVal vNewValue As Variant)
    m_Datas = vNewValue
    
End Property
Public Property Get Count() As Integer
On Error Resume Next
    Count = m_Count
    
End Property
Public Property Get IsNull() As Boolean
    IsNull = (Count = 0)
    
End Property

'ClassName:TlsSelectionSet
'Writer:xsfhlzh
'增强选择集
'暂不支持当前选择集
Private oSel As AcadSelectionSet
Private mFilter 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 mFilter.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
sName = oSel.Name
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 mFilter.IsNull Then
oSel.SelectOnScreen
Else
oSel.SelectOnScreen mFilter.TypeCodes, mFilter.Datas
End If
End Sub
Public Sub SelectSingleObject(Optional Prompt As String = "")
On Error GoTo ErrHandle
Dim obj As AcadEntity, pnt
If mFilter.IsNull Then
If Prompt = "" Then
ThisDrawing.Utility.GetEntity obj, pnt
Else
ThisDrawing.Utility.GetEntity obj, pnt, Prompt
End If
AddItems obj
Else
SelectObject acSelectionSetAll
Do
If Prompt = "" Then
ThisDrawing.Utility.GetEntity obj, pnt
Else
ThisDrawing.Utility.GetEntity obj, pnt, Prompt
End If
oCount = Count
RemoveItems obj
If oCount <> Count Then
Clear
AddItems obj
Exit Do
End If
Loop
End If
Exit Sub
ErrHandle:
Clear
End Sub
Public Sub SelectObject(ByVal Mode As AcSelect, Optional ByVal Point1, Optional ByVal Point2)
On Error Resume Next
If mFilter.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, , , mFilter.TypeCodes, mFilter.Datas
Else
oSel.Select Mode, Point1, Point2, mFilter.TypeCodes, mFilter.Datas
End If
End If
End Sub
Public Sub SelectAtPoint(ByVal Point)
On Error Resume Next
If mFilter.IsNull Then
oSel.SelectAtPoint Point
Else
oSel.SelectAtPoint Point, mFilter.TypeCodes, mFilter.Datas
End If
End Sub
Public Sub SelectByPolygon(ByVal Mode As AcSelect, Optional ByVal Points)
On Error Resume Next
If mFilter.IsNull Then
oSel.SelectByPolygon Mode, Points
Else
oSel.SelectByPolygon Mode, Points, mFilter.TypeCodes, mFilter.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 Function
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 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 = mFilter
If Err Then
Set mFilter = New TlsResultBuffer
Set Filter = mFilter
Err.Clear
End If
End Property
Private 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

'ClassName:TlsSelectionSet
'Writer:xsfhlzh
'增强选择集
'暂不支持当前选择集
Private oSel As AcadSelectionSet
Private mFilter 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 mFilter.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
    sName = oSel.Name
    
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 mFilter.IsNull Then
        oSel.SelectOnScreen
    Else
        oSel.SelectOnScreen mFilter.TypeCodes, mFilter.Datas
    End If
    
End Sub
Public Sub SelectSingleObject(Optional Prompt As String = "")
On Error GoTo ErrHandle
    Dim obj As AcadEntity, pnt
    If mFilter.IsNull Then
        If Prompt = "" Then
            ThisDrawing.Utility.GetEntity obj, pnt
        Else
            ThisDrawing.Utility.GetEntity obj, pnt, Prompt
        End If
        AddItems obj
    Else
        SelectObject acSelectionSetAll
        Do
            If Prompt = "" Then
                ThisDrawing.Utility.GetEntity obj, pnt
            Else
                ThisDrawing.Utility.GetEntity obj, pnt, Prompt
            End If
            oCount = Count
            RemoveItems obj
            If oCount <> Count Then
                Clear
                AddItems obj
                Exit Do
            End If
        Loop
    End If
    Exit Sub
ErrHandle:
    Clear
End Sub
Public Sub SelectObject(ByVal Mode As AcSelect, Optional ByVal Point1, Optional ByVal Point2)
On Error Resume Next
        
    If mFilter.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, , , mFilter.TypeCodes, mFilter.Datas
        Else
            oSel.Select Mode, Point1, Point2, mFilter.TypeCodes, mFilter.Datas
        End If
    End If
    
End Sub
Public Sub SelectAtPoint(ByVal Point)
On Error Resume Next
        
    If mFilter.IsNull Then
        oSel.SelectAtPoint Point
    Else
        oSel.SelectAtPoint Point, mFilter.TypeCodes, mFilter.Datas
    End If
    
End Sub
Public Sub SelectByPolygon(ByVal Mode As AcSelect, Optional ByVal Points)
On Error Resume Next
        
    If mFilter.IsNull Then
        oSel.SelectByPolygon Mode, Points
    Else
        oSel.SelectByPolygon Mode, Points, mFilter.TypeCodes, mFilter.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 Function
    
    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 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 = mFilter
    
    If Err Then
        Set mFilter = New TlsResultBuffer
        Set Filter = mFilter
        Err.Clear
    End If
    
End Property
Private 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

znyan · 发表于 2010-1-22 00:33:00

本帖最后由作者于 2010-1-23 11:45:16 编辑

看到这个帖子，真是太惊喜了。有了这个类，就可以集中精力研究那些更有用的东西了。

danberlove · 发表于 2010-1-22 08:44:00

进来学习的~

sullei · 发表于 2015-3-3 21:01:16

谢谢了，进来学习学习

mycad · 发表于 2015-3-10 17:25:56

雪山飞狐_lzh版主牛！学习了

账号		自动登录	找回密码
密码			注册