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

雪山飞狐_lzh · 发表于 2004-11-12 15:25

本帖最后由作者于 2006-3-16 14:27:42 编辑

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 AddItems(ByVal objs)
'向选择集加入实体
On Error Resume Next
If IsArray(objs) Then
oSel.AddItems objs
ElseIf IsObject(objs) Then
Dim ents(0) As AcadEntity
Set ents(0) = objs
oSel.AddItems ents
End If
End Sub
Public Sub RemoveItems(ByVal objs)
'在选择集中移除实体
On Error Resume Next
If IsArray(objs) Then
oSel.RemoveItems objs
ElseIf IsObject(objs) Then
Dim ents(0) As AcadEntity
Set ents(0) = objs
oSel.RemoveItems ents
End If
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 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 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 AppendFilter(ParamArray Filter())
Dim n As Integer, oCount As Integer, nCount As Integer
oCount = UBound(TlsFt)
nCount = (UBound(Filter) + 1) / 2
n = oCount + nCount
ReDim Preserve TlsFt(n), TlsFd(n)
For i = 0 To nCount - 1
n = oCount + i + 1
TlsFt(n) = Filter(i * 2)
TlsFd(n) = Filter(i * 2 + 1)
Next i
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 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

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 AddItems(ByVal objs)
'向选择集加入实体
On Error Resume Next
    
    If IsArray(objs) Then
        oSel.AddItems objs
    ElseIf IsObject(objs) Then
        Dim ents(0) As AcadEntity
        Set ents(0) = objs
        oSel.AddItems ents
    End If
    
End Sub
Public Sub RemoveItems(ByVal objs)
'在选择集中移除实体
On Error Resume Next
    
    If IsArray(objs) Then
        oSel.RemoveItems objs
    ElseIf IsObject(objs) Then
        Dim ents(0) As AcadEntity
        Set ents(0) = objs
        oSel.RemoveItems ents
    End If
    
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 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 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 AppendFilter(ParamArray Filter())
    Dim n As Integer, oCount As Integer, nCount As Integer
    oCount = UBound(TlsFt)
    nCount = (UBound(Filter) + 1) / 2
    n = oCount + nCount
    ReDim Preserve TlsFt(n), TlsFd(n)
    For i = 0 To nCount - 1
        n = oCount + i + 1
        TlsFt(n) = Filter(i * 2)
        TlsFd(n) = Filter(i * 2 + 1)
    Next i
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 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

ntchjie · 发表于 2004-11-12 15:54

沙发，谢谢了，能介绍一下吗？

nxy_918 · 发表于 2004-11-12 16:52

可否介绍一下，有哪些功能的增强？

雪山飞狐_lzh · 发表于 2004-11-12 19:30

比较一下下面两段代码，功能是一样的 Sub test1()
Dim ss As New TlsSel
ss.Init
ss.SetFilterType 0
ss.SetFilterData "Line"
ss.SelectObjectOnScreen
End Sub Sub test2()
On Error Resume Next
Dim ss As AcadSelectionSet
ThisDrawing.SelectionSets("TlsSel").Delete
Set ss = ThisDrawing.SelectionSets.Add("TlsSel")
Dim ft(0) As Integer, fd(0)
ft(0) = 0: fd(0) = "Line"
ss.SelectOnScreen ft, fd
ss.Delete
End Sub

ntchjie · 发表于 2004-11-12 20:24

收下了，仔细研究研究。简化了多。

mccad · 发表于 2004-11-12 20:49

建议增加一些常用属性的修改，如颜色、线型、图层等。以前象移动、复制等功能。这也是我以前想做的。
因为AX的选择集就这一点和LISP的选择集不同，操作起来也不方便。

雪山飞狐_lzh · 发表于 2004-11-12 22:21

本帖最后由作者于 2004-11-13 13:05:04 编辑

按照老大的意见已做更改，见一楼代码，大家看看还有什么要加的？

雪山飞狐_lzh · 发表于 2004-11-12 22:31

这是测试代码

Sub test1()
Dim ss As New TlsSel
ss.Init "TlsSel1"
ss.SetFilterType 0, 8
ss.SetFilterData "Line", "0"
ss.SelectObjectOnScreen
ss.GetBoundingBox p1, p2
' OutputPoint p1
' OutputPoint p2
ss.Move p1, p2
End Sub

nxy_918 · 发表于 2004-11-13 09:58

不错，有所增强

tiger8888 · 发表于 2004-11-14 18:07

不错也

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

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

本帖被以下淘专辑推荐: