请教vba编程中的一个问题

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

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

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

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

' 主程序
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

' 主程序 
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 = "

OLYLINE" Or ComboBox4.Text = "

OLYLINE" 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

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

我现在需要处理的正是这样的问题，我上面的程序就是将新生的对象加入到原选择集中进行处理，但总是无法取得新生的对象

mccad · 发表于 2003-10-11 18:40:00

这个问题要好好考虑考虑，其实后来想到的一种更好的方法是先求得每条线的交点列表，再求交点到线起点的距离，按距离排序所取得的交点，然后从最大的距离开始一个一个打断线，因为这样做原始的线是不会变的，也就是新生成的线不会再有交点了。
这是个思路，算法关键是排序的方法。

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

谢谢明总，我那程序开始怎么也不行，但后来好像没有改什么竟然又可以了。莫名其妙！

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