请教vba编程中的一个问题

longcs · 发表于 2003-10-10 11:46:00

各位大虾:
我有一个程序将图形内的所有相交实体打断，用vba开发过程中是调用break实现的，但打断后新增加的实体(原有一个实体变成两个实体)在程序运行过程中无法加入到原有的选择集合中，也就是无法进行递归处理,用thisdrawing.modespace.count得出的实体数目与打断前一样，同样思路用LISP可以实现，请各位指教!

mccad · 发表于 2003-10-10 12:16:00

你的程序是怎样的，我试过了，正常，没出现你说的现象。

copy


' 主程序
Sub DispBreakMun()
    Debug.Print "打断前的图元数目：" & ThisDrawing.ModelSpace.Count
    Call Break
    Debug.Print "打断后的图元数目：" & ThisDrawing.ModelSpace.Count
End Sub
'示例Break
Sub Break()
    Dim Pnt As Variant
    Dim entObj As AcadEntity
    ThisDrawing.Utility.GetEntity entObj, Pnt, "选择图元："
    Dim Pnt2 As Variant
    Pnt2 = ThisDrawing.Utility.GetPoint(, "选择点：")
    Dim det As String
    det = GetDoubleEntTable(entObj, Pnt)
    Dim lspPnt As String
    lspPnt = axPoint2lspPoint(Pnt2)
    ThisDrawing.SendCommand "_break" & vbCr & det & vbCr & lspPnt & vbCr
End Sub
'示例Trim
Sub Trim()
    Dim Pnt1 As Variant
    Dim entObj1 As AcadEntity
    ThisDrawing.Utility.GetEntity entObj1, Pnt1, "选择图元："
    Dim det1 As String
    det1 = axEnt2lspEnt(entObj1)
    Dim Pnt2 As Variant
    Dim entObj2 As AcadEntity
    ThisDrawing.Utility.GetEntity entObj2, Pnt2, "选择被剪图元："
    Dim det2 As String
    det2 = GetDoubleEntTable(entObj2, Pnt2)
    ThisDrawing.SendCommand "_trim" & vbCr & det1 & vbCr & vbCr & det2 & vbCr & vbCr
End Sub
'转换双元表的函数
Public Function GetDoubleEntTable(entObj As AcadEntity, Pnt As Variant) As String
    Dim entHandle As String
    entHandle = entObj.Handle
    GetDoubleEntTable = "(list(handent " & Chr(34) & entHandle & Chr(34) & _
                     ")(list " & Str(Pnt(0)) & Str(Pnt(1)) & Str(Pnt(2)) & "))"
End Function
'转换点的函数
Public Function axPoint2lspPoint(Pnt As Variant) As String
    axPoint2lspPoint = Pnt(0) & "," & Pnt(1) & "," & Pnt(2)
End Function
'转换图元函数
Public Function axEnt2lspEnt(entObj As AcadEntity) As String
    Dim entHandle As String
    entHandle = entObj.Handle
    axEnt2lspEnt = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
End Function

longcs · 发表于 2003-10-11 10:34:00

请mccad在cad2000下随意绘制几条稍微复杂的互相相交的多义线
程序代码如下:
Private Sub CommandButton3_Click()
  Dim GpCode(0 To 1) As Integer    '选择集过滤
  Dim DataValue(0 To 1) As Variant '选择集过滤
  Dim n As Integer, m As Integer    '选择集中实体的个数
  Dim i As Integer, j As Integer, k As Integer, l As Integer  '四层循环控制
  Dim Startime As Date                '起始运行时间
  Startime = Time()
  Dim En As Variant                   '第一层循环实体名
  Dim En1 As Variant                   '第二层循环实体名
  Dim Minext As Variant                '实体的外界多边形左下角点(二维点)
  Dim Maxext As Variant                '实体的外界多边形右上角点(二维点)
  Dim Vert1(0 To 2) As Double          '实体的外界多边形左下角点(三维点)
  Dim Vert2(0 To 2) As Double          '实体的外界多边形右上角点(三维点)
  Dim Intpoints As Variant             '返回的交点集
  Dim Cir As AcadCircle                '增加的标志，圆
  Dim Pt(0 To 2) As Double             '交点坐标
  Dim Pts As Variant                   '实体的端点坐标集
  Dim Pts1 As Variant                   '实体的端点坐标集
  Dim isxj As Boolean                   '是否端点的标志
  Dim Myss As AcadSelectionSet          '定义第一层循环选择集"myss"
  Dim Myss1 As AcadSelectionSet       '定义第二层循环选择集"myss1"
  Dim Myss2 As AcadSelectionSet       '定义第三层循环选择集"myss2"
  Dim ThisCoord() As coord
  Dim lspPnt As String
  Dim det As String
  Dim LastArray(0) As Variant
  Dim inti As Integer
  Dim intj As Integer

  '得到多义线过滤代码
  GpCode(0) = 8
  GpCode(1) = 0
  DataValue(0) = "0"
  DataValue(1) = "lwpolyline"

  For Each Myss In ThisDrawing.SelectionSets '如选择集"myss"存在则删除
If Myss.Name = "sset" Then
   Myss.Delete
   Exit For
End If
  Next
  For Each Myss1 In ThisDrawing.SelectionSets '如选择集"myss1"存在则删除
If Myss1.Name = "sset1" Then
   Myss1.Delete
   Exit For
End If
  Next

  Set Myss = ThisDrawing.SelectionSets.Add("sset")    '添加选择集myss
  Set Myss1 = ThisDrawing.SelectionSets.Add("sset1")    '添加选择集myss1
  ThisDrawing.SetVariable "clayer", ComboBox5.Text    '设置当前的图层

  Myss.Select acSelectionSetAll, , , GpCode, DataValue '选择所有的特定线


  '相交线打断
For i = 0 To Myss.Count - 1                                  '外循环，控制图形中所有的界址线
Set En = Myss.Item(i)
Call En.GetBoundingBox(Minext, Maxext)                      '选择包含多义线外框内的所有实体
Vert1(0) = Minext(0): Vert1(1) = Minext(1): Vert1(2) = 0#
Vert2(0) = Maxext(0): Vert2(1) = Maxext(1): Vert2(2) = 0#
'选择与宗地相交的所有的界址线
Myss1.Select acSelectionSetCrossing, Vert1, Vert2, GpCode, DataValue
   For j = 0 To Myss1.Count - 1                                     '控制所有与外循环中实体相交的实体
   Set En1 = Myss1.Item(j)
   If ComboBox2.Text = &quotOLYLINE" Or ComboBox4.Text = &quotOLYLINE" Then
      setn = 3
      ElseIf ComboBox2.Text = "LWPOLYLINE" Or ComboBox4.Text = "LWPOLYLINE" Then
      setn = 2
   End If
      If En1.Handle  En.Handle Then                      '如为自身，则跳过
      Intpoints = En.IntersectWith(En1, acExtendNone)
      If VarType(Intpoints)  vbEmpty Then                '如存在交点则依次取得交点的坐标
         For k = LBound(Intpoints) To UBound(Intpoints) Step 3
               Pt(0) = Intpoints(k): Pt(1) = Intpoints(k + 1): Pt(2) = Intpoints(k + 2)
                        det = "(list(handent " & Chr(34) & En.Handle & Chr(34) & ")(list " & str(Pt(0)) & str(Pt(1)) & str(Pt(2)) & "))"
      lspPnt = axPoint2lspPoint(Pt)
      ThisDrawing.SendCommand "_break" & vbCr & det & vbCr & "f" & vbCr & lspPnt & vbCr & lspPnt & vbCr
      '程序运行到下面这行代码总提示错误
      Myss.AddItems ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)  '将打断后新增加的实体加入到原选择集进行递归处理
      Exit For
         Next k
      End If
   End If
   Next j
Next i
End Sub

longcs · 发表于 2003-10-11 10:36:00

急切盼望大虾的指点，不胜感激

longcs · 发表于 2003-10-11 16:34:00

明总：
这是你曾经的回贴
这个问题可能没这么简单，因为：
断开后对象会变成两个对象，而程序的继操作只是对断开后的一个对象进行操作，而新生成的对象不做操作。但如果考虑新生成的对象，则这种操作就会变成很多的循环。这也是难点。
我想能不能先不要断开，而只取得每个对象上的断开点，再根据对象的属性重新生成对象，这样可能工作量会大点，而且对于某些对象可能不太适合，如样条曲线。
如果能够从末端开始进行断开操作，则下一个断开点还可以保留在源对象上，这可能可行，但这些点怎样排序，又是一个问题。
我现在需要处理的正是这样的问题，我上面的程序就是将新生的对象加入到原选择集中进行处理，但总是无法取得新生的对象