请看看该程序到底什么问题？

topirol

是根据VBA教材的代码改的批量裁剪程序


问题：达不到裁减效果（我想把多边行内的线条裁剪掉），但有时候又可以，纳闷！
[/CODE]

[CODE]

Sub Trim()
    Dim acadapp As AcadApplication
    Dim acaddoc As AcadDocument
   
    Set acadapp = connectcad(acadapp)
    Set acaddoc = acadapp.ActiveDocument
    AppActivate acadapp.Caption '让CAD得到焦点
   
   
    Dim Pnt1 As Variant
    Dim entObj1 As AcadEntity
    acaddoc.Utility.GetEntity entObj1, Pnt1, "选择修剪边界："
    Dim det1 As String
    det1 = axEnt2lspEnt(entObj1)

    Dim Pnt2 As Variant
    Dim entObj2 As AcadEntity
   
    Dim sle1 As AcadSelectionSet
   
   
    On Error Resume Next
   
    Set sle1 = acaddoc.SelectionSets.Item("sle1")
    sle1.Clear
    If Err Then
    Err.Clear
    Set sle1 = acaddoc.SelectionSets.Add("sle1")
    End If
   
    acaddoc.Utility.Prompt "选择需要修剪的对象" & Chr(13)
   
    sle1.SelectOnScreen
   
    Pnt2 = acaddoc.Utility.GetPoint(, "选择修剪方向")
    Dim det2 As String
   
    For Each entObj2 In sle1
    det2 = GetDoubleEntTable(entObj2, Pnt2)

    acaddoc.SendCommand "_trim" & vbCr & det1 & vbCr & vbCr & det2 & vbCr & vbCr
    Next
   
   
   
    Dim command_str As String
    command_str = Chr(3) & Chr(3)
    acaddoc.SendCommand command_str
    acaddoc.Utility.Prompt "修剪完成!"
    acaddoc.SendCommand command_str
   
    Set acadapp = Nothing
    End
   

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


Function connectcad(acadapp As AcadApplication) As AcadApplication '连接AutoCAD


On Error Resume Next
     
    '与autocad通信
     
    Set acadapp = GetObject(, "AutoCAD.Application")
    If Err Then
        Err.Clear
        Set acadapp = CreateObject("AutoCAD.Application")
        If Err Then
            MsgBox Err.Description
            Exit Function
        End If
    End If
Set connectcad = acadapp
End Function

Private Sub Form_Initialize()
Trim
End Sub

topirol

是不是“转换双元表的函数”不能完全达到效果呢？

mccad

你的程序本身有问题：
在选择修剪方向时，其实你只认定了一个点Pnt2，然后你就使用该点组成了修剪的双元表，这样的话，对于被修剪对象来说，可能会产生点取的点在外部的问题，因为系统认定的点取的位置是Pnt2到被修剪对象上的垂直点的位置。
要达到效果，应该是：
点取一个点Pnt2后，把多段线向内偏移一小段距离，然后逐条遍历被修剪对象的选择集，求选择集中的对象与偏移的对象的交点，再通过交点来组成双元表，这样的话，应该可以解决。

topirol

：）非常感谢！其实我还是不了解“双元表”的概念，不知道是什么东西，有什么用，因为都找不到这方面的参考书

mccad

双元表也就是指在进行一些对象操作时对位置有要求时使用数据格式