RICVBA 发表于 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.EntityTypemyEnt.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


米秀 发表于 2014-1-30 02:46:41

你好，Robert98，你克服这个问题了吗
否则，请告诉我您&#039；我们还在挣扎
然而，乍一看我&#039；注意下面的内容：
-；d投诉不#039的用户；t选择myEnt作为LWPolyline（“MsgBox”未选择多段线！？“vbCritical”）但是，如果他选择myEnt作为LWPolyline，那么例程就不会&35;039；从那以后我什么都不做；如果是Ent。实体类型&lt&燃气轮机；迈恩。实体类型“；“内部控制”；对于SSet中的每个Ent“；循环将始终返回“；“假”；（SSet.Select标准将仅收集“LWPolyline”类型元素），并且永远不会填充MyCords向量
这样，您的例程只处理属于具有相同颜色和a层的轻量级多段线的坐标；非轻型多段线“；实体：这就是你&#039；你的目标是什么
说明书；MyCords（i）=耳鼻喉科。坐标“；不会&#039；t工作，因为；坐标“；属性返回一个变体。此外，它会返回多个值（“对象中每个顶点的坐标”）不能只放在一个向量位置，例如；MyCords（i）”；。最后你没有&#039；t使用任何ReDim指令来生成；MyCords“；向量可以用新的坐标填充，因此您应该首先声明一个变量来收集实体坐标，并最终通过循环将其倒入myCoords向量中。所有这些始终跟踪向量维度（即：适当地重新命名它们）。例如：
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.EntityTypemyEnt.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
再见

小罗 发表于 2014-1-30 18:17:44

您好，RECVBA，非常感谢您的支持&nbsp；尊敬的，It；似乎继续下去是个好主意，但我&#039；我现在正在进行实地工作，因此很快我&#039；我要去编程了。真的，罗伯特
页: [1]
查看完整版本: 选择集和过滤