[求助]：请问VB下如何实现extrim的功能

qijiun

我想用vb实现extrim的功能，现在已经把程序编出来了
但是就是不能修剪，在向cad传命令的时候，trim的"f"
模式好像不管用的，烦请各位大侠帮忙看看
这样的思路可行吗？

Sub sdstr()
On Error GoTo Err_Control
Dim StrFilterType As Variant, StrFilterData As Variant
Dim Gpcode(1) As Integer, Datavalue(1) As Variant
Dim StrSset As AcadSelectionSet
Dim StrVbPnt As Variant
Dim StrLspPnt(2) As Double
Dim StrlspTmpPnt1(2), StrlspTmpPnt2(2) As Double
Dim StrVbLinePnt(1) As Variant
Dim StrLspLinePnt1(2), StrLspLinePnt2(2) As Double
Dim i, j, k As Double
Dim l, m, n As Integer

Gpcode(0) = 0
    Datavalue(0) = "line"
    Gpcode(1) = 0
    Datavalue(1) = "line"
   StrFilterType = Gpcode
StrFilterData = Datavalue
'初始化选择集
If ThisDrawing.SelectionSets.Count <> 1 Then
For g = 0 To ThisDrawing.SelectionSets.Count - 1
ThisDrawing.SelectionSets.Item(g).Clear
ThisDrawing.SelectionSets.Item(g).Delete
Next
End If
Set StrSset = ThisDrawing.SelectionSets.Add("StrSset")
StrSset.Highlight True
StrSset.Update
' 提示用户选择对象并将它们添加到选择集中。
ThisDrawing.Utility.Prompt "请选择剪切边界："
StrSset.SelectOnScreen StrFilterType, StrFilterData
StrVbPnt = ThisDrawing.Utility.GetPoint(, "指定要修剪的一侧：")
            StrLspPnt(0) = StrVbPnt(0) '取得修剪边的坐标
      StrLspPnt(1) = StrVbPnt(1)
            StrLspPnt(2) = StrVbPnt(2)
For Each Entry In StrSset
StrVbLinePnt(0) = Entry.StartPoint '获得直线的坐标
StrVbLinePnt(1) = Entry.EndPoint
StrLspLinePnt1(0) = StrVbLinePnt(0)(0) '对直线坐标进行赋值
StrLspLinePnt1(1) = StrVbLinePnt(0)(1)
StrLspLinePnt2(0) = StrVbLinePnt(1)(0)
StrLspLinePnt2(1) = StrVbLinePnt(1)(1)
'得到第一个辅助点
StrlspTmpPnt1(0) = StrLspLinePnt1(0) + 10 * Cos(Atn((StrLspLinePnt1(1) - StrLspPnt(1)) / (StrLspLinePnt1(0) - StrLspPnt(0))))
StrlspTmpPnt1(1) = StrLspLinePnt1(1) + 10 * Sin(Atn((StrLspLinePnt1(1) - StrLspPnt(1)) / (StrLspLinePnt1(0) - StrLspPnt(0))))
StrlspTmpPnt1(2) = 0
'得到第二个辅助点
StrlspTmpPnt2(0) = StrLspLinePnt2(0) - 10 * Cos(Atn((StrLspLinePnt2(1) + StrLspPnt(1)) / (StrLspLinePnt2(0) - StrLspPnt(0))))
StrlspTmpPnt2(1) = StrLspLinePnt2(1) - 10 * Sin(Atn((StrLspLinePnt2(1) + StrLspPnt(1)) / (StrLspLinePnt2(0) - StrLspPnt(0))))
StrlspTmpPnt2(2) = 0
ThisDrawing.SendCommand "_zoom" & vbCr & "extents" & vbCr
Call ThisDrawing.SendCommand("_trim" & vbCr & "(handent " & Chr(34) & Entry.Handle & Chr(34) & ")" & vbCr & "f" & vbCr & StrlspTmpPnt1(0) & "," & StrlspTmpPnt1(1) _
& vbCr & StrlspTmpPnt2(0) & "," & StrlspTmpPnt2(1) & " " & vbCr & " " & vbCr)
'检查临时选择线条的位置
'ThisDrawing.SendCommand ("_line" & vbCr & StrlspTmpPnt1(0) & "," & StrlspTmpPnt1(1) & vbCr & StrlspTmpPnt2(0) & "," & StrlspTmpPnt2(1) & vbCr)
Next Entry
Err_Control:
StrSset.Delete
End Sub

cyt4321

例子：
来源：  明经通道 　作(译)者：  郑立楷

'示例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

qijiun

能够修剪了，但是有些线条修剪得不对，不知为何
还请大侠指点！
Sub sdstr()
On Error GoTo Err_Control
Dim StrFilterType As Variant, StrFilterData As Variant
Dim Gpcode(1) As Integer, Datavalue(1) As Variant
Dim StrSset As AcadSelectionSet
Dim StrVbPnt As Variant
Dim StrLspPnt(2) As Double
Dim StrlspTmpPnt1(2), StrlspTmpPnt2(2) As Double
Dim StrVbLinePnt(1) As Variant
Dim StrLspLinePnt1(2), StrLspLinePnt2(2) As Double
Dim Length, Temp As Double

Gpcode(0) = 0
    Datavalue(0) = "line"
    Gpcode(1) = 0
    Datavalue(1) = "line"
   StrFilterType = Gpcode
StrFilterData = Datavalue
'初始化选择集
If ThisDrawing.SelectionSets.Count <> 1 Then
For g = 0 To ThisDrawing.SelectionSets.Count - 1
ThisDrawing.SelectionSets.Item(g).Clear
ThisDrawing.SelectionSets.Item(g).Delete
Next
End If
Set StrSset = ThisDrawing.SelectionSets.Add("StrSset")
StrSset.Highlight True
StrSset.Update
' 提示用户选择对象并将它们添加到选择集中。
' 要完成选择，按回车。
ThisDrawing.Utility.Prompt "请选择剪切边界："
StrSset.SelectOnScreen StrFilterType, StrFilterData
StrVbPnt = ThisDrawing.Utility.GetPoint(, "指定要修剪的一侧：")
            StrLspPnt(0) = StrVbPnt(0) '取得修剪边的坐标
            StrLspPnt(1) = StrVbPnt(1)
            StrLspPnt(2) = StrVbPnt(2)
For Each Entry In StrSset
StrVbLinePnt(0) = Entry.StartPoint '获得直线的坐标
StrVbLinePnt(1) = Entry.EndPoint
StrLspLinePnt1(0) = StrVbLinePnt(0)(0) '对直线坐标进行赋值
StrLspLinePnt1(1) = StrVbLinePnt(0)(1)
StrLspLinePnt2(0) = StrVbLinePnt(1)(0)
StrLspLinePnt2(1) = StrVbLinePnt(1)(1)
'对点进行位置的确认
If (StrLspLinePnt1(0) > StrLspLinePnt2(0)) Then
Temp = StrLspLinePnt1(0)
StrLspLinePnt1(0) = StrLspLinePnt2(0)
StrLspLinePnt2(0) = Temp
Temp = StrLspLinePnt1(1)
StrLspLinePnt1(1) = StrLspLinePnt2(1)
StrLspLinePnt2(1) = Temp
ElseIf (StrLspLinePnt1(0) = StrLspLinePnt2(0)) Then
If (StrLspLinePnt1(1) > StrLspLinePnt2(1)) Then
Temp = StrLspLinePnt1(0)
StrLspLinePnt1(0) = StrLspLinePnt2(0)
StrLspLinePnt2(0) = Temp
Temp = StrLspLinePnt1(1)
StrLspLinePnt1(1) = StrLspLinePnt2(1)
StrLspLinePnt2(1) = Temp
End If
End If

'判断点在直线的哪一侧
Temp = StrLspLinePnt1(1) + (StrLspPnt(0) - StrLspLinePnt1(0)) * (StrLspLinePnt2(1) - StrLspLinePnt1(1)) / (StrLspLinePnt2(0) - StrLspLinePnt1(0))
If Temp > StrLspPnt(1) Then
StrLspLinePnt1(1) = StrLspLinePnt1(1) - 1
Else: StrLspLinePnt1(1) = StrLspLinePnt1(1) + 1
End If
'修剪直线
ThisDrawing.SendCommand "_zoom" & vbCr & "extents" & vbCr
Call ThisDrawing.SendCommand("_trim" & vbCr & "(handent " & Chr(34) & Entry.Handle & Chr(34) & ")" & vbCr & vbCr & "f" & vbCr & StrLspLinePnt1(0) & "," & StrLspLinePnt1(1) _
& vbCr & StrLspLinePnt2(0) & "," & StrLspLinePnt2(1) & " " & vbCr & vbCr)

ThisDrawing.SendCommand "_zoom" & vbCr & "p" & vbCr
Next Entry
Err_Control:
StrSset.Delete
End Sub

zcmjw

使用对象的交点方法，应该能行。

zhangzongwei

你能不说写些简单点的

wyhph

好东西，我要借鉴！