- 积分
- 274
- 明经币
- 个
- 注册时间
- 2012-3-29
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
在网上搜集合并多段线的代码,运行了,还是合并不了,估计问题出在选择对象上,希望大家指导下:
' 转换多个图元的函数
Public Function axSSet2lspEnts(ByVal SSet As AcadSelectionSet) As String
If SSet.Count = 0 Then Exit Function
Dim entHandle As String
Dim strEnts As String
entHandle = SSet.Item(0).Handle
strEnts = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
If SSet.Count > 1 Then
Dim i As Integer
For i = 1 To SSet.Count - 1
entHandle = SSet.Item(i).Handle
strEnts = strEnts & vbCr & "(handent " & Chr(34) & entHandle & Chr(34) & ")"
Next i
End If
axSSet2lspEnts = strEnts
End Function
' 连接多段线
Public Function EditPline(ByVal pt1 As Variant, ByVal pt2 As Variant) As AcadPolyline
On Error Resume Next
Dim det As Variant
Dim FilterType As Integer
Dim FilterData As Variant
FilterType = 0 '按类型选择
FilterData = "Polyline"
Dim SSet As AcadSelectionSet
If Not IsNull(ThisDrawing.SelectionSets.Item("PLineSet")) Then
Set SSet = ThisDrawing.SelectionSets.Item("PLineSet")
SSet.Delete
End If
Set SSet = ThisDrawing.SelectionSets.Add("PLineSet")
SSet.Delete
SSet.Select acSelectionSetCrossing, pt1, pt2, FilterType, FilterData
det = axSSet2lspEnts(SSet)
' 使用SendCommand听后方法完成连接操作
ThisDrawing.SendCommand "_PEDIT" & vbCr & "M" & vbCr & det & vbCr & "J" & vbCr & det & "0.000" & vbCr & vbCr
End Function
|
|