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

雪山飞狐(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

'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

好顶一个

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

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

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子