社区 › VB › 打断程序问题：有时候可以运行，有时候不能

liuyang4740 发表于 2008-11-14 10:33:00

打断程序问题：有时候可以运行，有时候不能

源程序如下：
Sub r4()                        '打断
    Dim returnObj As AcadEntity
    Dim x(2), y(2) As Double
    Dim ss(100000) As Variant
    Dim det As String
    Dim det1 As String
    Dim lspPnt As String
    Dim minp, maxp As Variant
    Dim ssetobj, ssetobj2 As AcadSelectionSet
    Dim ent As AcadEntity
    'ScreenUpdating = False
   
    On Error Resume Next
    SsetName = "au100"
    On Error Resume Next
    For i = 0 To ThisDrawing.SelectionSets.Count - 1
      Set ssetobj = ThisDrawing.SelectionSets.Item(i)
       If ssetobj.Name = "au100" Then ssetobj.Delete
    Next i
       Set ssetobj = ThisDrawing.SelectionSets.Add(SsetName)
       ssetobj.SelectOnScreen
      
       k = 0

       j = ssetobj.Count
   For i = 0 To j - 1
      For ii = 0 To j - 1
          If Abs(ssetobj.Item(i).Angle - ssetobj.Item(ii).Angle) > 0.5 Then
            ss(k) = ssetobj.Item(i).IntersectWith(ssetobj.Item(ii), acExtendBoth)
            det = GetDoubleEntTable(ssetobj.Item(i), ss(k))
            det1 = GetDoubleEntTable(ssetobj.Item(ii), ss(k))
            lspPnt = axPoint2lspPoint(ss(k))
            ThisDrawing.SendCommand "_break" & vbCr & det & vbCr & lspPnt & vbCr
            ThisDrawing.SendCommand "_break" & vbCr & det1 & vbCr & lspPnt & vbCr
            k = k + 1
          End If
      Next
   Next
   
    SsetName = "au101"
    On Error Resume Next
    For i = 0 To ThisDrawing.SelectionSets.Count - 1
      Set ssetobj2 = ThisDrawing.SelectionSets.Item(i)
       If ssetobj2.Name = "au101" Then ssetobj2.Delete
    Next i
       Set ssetobj2 = ThisDrawing.SelectionSets.Add(SsetName)
                        
          ssetobj2.SelectOnScreen          '删除打断中产生的小雨1000的直线
      For Each returnObj In ssetobj2
      If returnObj.Length
'转换双元表的函数
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

liuyang4740 发表于 2008-11-20 12:24:00

高手请指教阿

mccad 发表于 2008-11-22 12:45:00

关闭对象捕捉试试。另外屏幕外的对象是无法操作的。

liuyang4740 发表于 2008-11-25 09:55:00

还是不行啊，如果不建立第二个选择集，打断可以实现，建立第二个选择集之后，连打断都不能实现啊？请问楼上的，是否是选择集相冲突呢？

查看完整版本: 打断程序问题：有时候可以运行，有时候不能