选择集和筛选

Robert98 · 发表于 2014-1-18 01:38:50

亲爱的会员嗨，
我已经很久没有autocad定制了很长时间，现在我想创建一些折线坐标的数组，然后删除重复的坐标，所以我写了我的日常工作，但它在第一阶段有一些错误。

谢谢，祝您度过美好时光。

Private Sub CommandButton4_Click()
Me.Hide
Dim myEnt As AcadEntity
Dim Pot(0 To 2) As Double
Dim myLay As Variant
Dim myCol As Variant
ThisDrawing.Utility.GetEntity myEnt, Pot, "Select yout lwpolyline"
     If TypeOf myEnt Is AcadLWPolyline Then
        myLay = myEnt.Layer
        myCol = myEnt.color
          Else
            MsgBox "Not selected a polyline !?", vbCritical
     End If
 
    Dim SSet As AcadSelectionSet
    Dim FilterType(0 To 2) As Integer
    Dim FilterData(0 To 2) As Variant
    Dim Groupcode As Variant
    Dim DataValue As Variant
    Dim myCoords() As Double
    FilterType(0) = 0
    FilterData(0) = "LWPolyline"
    FilterType(1) = 8
    FilterData(1) = myEnt.Layer
    FilterType(2) = 62
    FilterData(2) = myEnt.color
 
    Groupcode = FilterType
    DataValue = FilterData
 
    On Error Resume Next
    ActiveDocument.SelectionSets.Item("MY_SSL").Delete
    Set SSet = ActiveDocument.SelectionSets.Add("MY_SSL")
    On Error GoTo 0
 
    SSet.Select acSelectionSetAll, , , Groupcode, DataValue
        
       Dim Ents() As Object
       Dim Ent As Object
       Dim i As Long
        i = 0
          For Each Ent In SSet
             If Ent.EntityType  myEnt.EntityType Then
                ReDim Preserve Ents(0 To i)
                Set Ents(i) = Ent
                ReDim Preserve Ents(0 To i)
                myCoords(i) = Ent.Coordinates
                i = i + 1
             End If
          Next Ent
           If i > 0 Then
                SSet.RemoveItems (Ents)
           End If
                For i = 0 To UBound(myCoords) - 1
                  Debug.Print myCoords(i), myCoords(i + 1)
                Next i
UserForm1.Show
End Sub

本帖以下内容被隐藏保护；需要你回复后，才能看到！

游客，如果您要查看本帖隐藏内容请回复

RICVBA · 发表于 2014-1-30 02:46:41

你好，Robert98
这个问题你解决了吗？
否则，请让我知道您还在纠结什么。
但是，第一眼我会注意到下面的内容:
-似乎您会抱怨用户没有选择myEnt作为LWPolyline ("MsgBox "没有选择Polyline！？"，vbCritical ")但是，如果他选择myEnt作为LWPolyline，那么例程不会做任何事情，因为" if Ent。EntityType myEnt。SSet”循环中每个Ent的entity type“control inside”将始终返回“False”(SSet。选择标准将只收集“LWPolyline”类型的元素)并且myCoords向量永远不会被填充。
所以您的例程只处理与“非轻量级折线”实体具有相同颜色和图层的轻量级折线的坐标:这是您的目标吗？
-指令“my cords(I)= Ent。坐标”不起作用，因为“坐标”属性会返回一个变量。此外，它返回不止一个值(“对象中每个顶点的坐标”)，这些值不能只放入一个向量位置，例如“my cords(I)”。最后，您没有使用任何ReDim指令来使“my cords”向量能够填充新的坐标
,因此您应该首先声明一个变量来收集实体坐标，并最终通过循环将它们注入my cords向量中。所有这些总是保持对向量尺寸的跟踪(即:适当地重新定义它们)。例如:

copy

Option Explicit
Private Sub CommandButton4_Click()
Me.Hide
Dim myEnt As AcadEntity
Dim Pot(0 To 2) As Double
Dim myLay As Variant
Dim myCol As Variant
ThisDrawing.Utility.GetEntity myEnt, Pot, "Select yout lwpolyline"
If TypeOf myEnt Is AcadLWPolyline Then
    myLay = myEnt.Layer
    myCol = myEnt.color
Else
    MsgBox "Not selected a polyline !?", vbCritical
End If
Dim SSet As AcadSelectionSet
Dim FilterType(0 To 2) As Integer
Dim FilterData(0 To 2) As Variant
Dim Groupcode As Variant
Dim DataValue As Variant
Dim myCoords() As Double
FilterType(0) = 0
FilterData(0) = "LWPolyline"
FilterType(1) = 8
FilterData(1) = myEnt.Layer
FilterType(2) = 62
FilterData(2) = myEnt.color
Groupcode = FilterType
DataValue = FilterData
On Error Resume Next
ActiveDocument.SelectionSets.Item("MY_SSL").Delete
Set SSet = ActiveDocument.SelectionSets.Add("MY_SSL")
On Error GoTo 0
SSet.Select acSelectionSetAll, , , Groupcode, DataValue
    
Dim Ents() As Object
Dim Ent As Object
Dim i As Long, j As Long, UBRetCoords As Long, UBMyCoords As Long
Dim retCoords As Variant
i = 0
For Each Ent In SSet
    If Ent.EntityType  myEnt.EntityType Then
        ReDim Preserve Ents(0 To i)
        Set Ents(i) = Ent
        ReDim Preserve Ents(0 To i)
        i = i + 1
        
        retCoords = Ent.Coordinates
        UBRetCoords = UBound(retCoords)
        
        'handle the first time you have to fill myCoords
        On Error Resume Next
        UBMyCoords = UBound(myCoords)
        If Err Then UBMyCoords = -1
        On Error GoTo 0
        
        ' fill myCoords
        ReDim Preserve myCoords(0 To UBMyCoords + UBRetCoords + 1)
        For j = 0 To UBRetCoords
            myCoords(UBMyCoords + j + 1) = retCoords(j)
        Next j
        
    End If
Next Ent
If i > 0 Then
    SSet.RemoveItems (Ents)
End If
For i = 0 To UBound(myCoords) - 1
    Debug.Print myCoords(i), myCoords(i + 1)
Next i
UserForm1.Show
End Sub

再见

Robert98 · 发表于 2014-1-30 18:17:44

你好，雷克巴
非常感谢你的问候，继续下去似乎是个好主意，但我现在正在进行实地工作，因此很快我就要开始编程了。
罗伯特，你说得对

选择集和筛选

发表回复

精选推荐