好像多数高手们都回家了,请教一个问题
先祝各位早年愉快!我想做一个将同一直线上的两条线段合并的程序,基本思路如下:
1.选择两个实体,如果是line或polyline则继续
2.将两条线段的四个端点分别赋值给pnt1,pnt2,pnt3,pnt4
3.将pnt1~4重新排列,使pnt1为x坐标最小的点,pnt4为x坐标最大的点.
4.若pnt1,pnt2的角度与pnt3,pnt4的角度相等,则说明四个点在一条直线上,继续.否则退出.
5.将第一个实体的两个端点分别设为pnt1和pnt4
6.删除第二个实体.结束
下面是部分未完成的代码:
Sub uniteline()
Dim line1 As AcadEntity, line2 As AcadEntity
Dim pnt1 As Variant, pnt2 As Variant, pnt3 As Variant, pnt4 As Variant, basepnt As Variant
choose1:
ActiveDocument.Utility.GetEntity line1, basepnt, "选择第一根线段:"
If line1.ObjectName = "AcDbLine" Then
pnt1 = line1.StartPoint: pnt2 = line1.EndPoint
Else
GoTo choose1
End If
choose2:
ActiveDocument.Utility.GetEntity line2, basepnt, "选择第二根线段:"
If line2.Handle = line1.Handle Then
ActiveDocument.Utility.Prompt "线段二与线段一重复,请重新选择"
GoTo choose2
Else
End If
If line2.ObjectName = "AcDbLine" Then
pnt3 = line2.StartPoint: pnt4 = line2.EndPoint
Else
GoTo choose1
End If
If pnt1(0) > pnt2(0) Then
basepnt = pnt1
pnt1 = pnt2
pnt2 = basepnt
End If
If pnt1(0) > pnt3(0) Then
basepnt = pnt1
pnt1 = pnt3
pnt3 = basepnt
End If
If pnt1(0) > pnt4(0) Then
basepnt = pnt1
pnt1 = pnt4
pnt4 = basepnt
End If
If pnt4(0) < pnt3(0) Then
basepnt = pnt4
pnt4 = pnt3
pnt3 = basepnt
End If
If pnt4(0) < pnt2(0) Then
basepnt = pnt4
pnt4 = pnt2
pnt2 = basepnt
End If
If Abs(((pnt2(1) - pnt1(1)) / (pnt2(0) - pnt1(0))) - ((pnt4(1) - pnt3(1)) / (pnt4(0) - pnt3(0)))) < 0.000001 Then'待改进
line1.StartPoint = pnt1: line1.EndPoint = pnt4
line2.Delete
Else
ActiveDocument.Utility.Prompt "线段一与线段二不在同一直线上,无法合并."
End If
End Sub
执行过程中遇到几个问题:
1.由于不知道选择的是line还是polyline,所以将line1.line2定义为acadentity,但这样无法获得线段的startpoint和endpoint(但可以通过监视窗口看到),如果定义为acadline则可以获得其端点.
2.如何判断获得的polyline是直线还是曲线,包括多顶点的polyline.
3.如何在加载dvb时在命令行执行一个命令定义代码,如明总那个对齐程序,加载时执行(defun c:eo()(vl-vbarun "arrangeent")(princ))(princ) 1.只要图元是直线，就有StartPoint和EndPoint属性，不论其定义为AcadEntity或AcadLine，你也可以在
If line2.ObjectName = "AcDbLine" Then
后增加
Dim Line_2 as AcadLine
Set Line_2 = line2
来定义。
2.判断多段线的类型，可以使用多段线的Type属性，只有其值为acSimplePoly才为一般的多段线。
3.呵呵，你只要增加以下代码就行，利用的是EndCommand事件,看看我在那个程序中的源码吧：
Public TestLoad As Boolean
Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
If Not TestLoad Then
ThisDrawing.SendCommand "(defun c:ao()(vl-vbarun ""alignent"")(princ))(princ)" & vbCr
ThisDrawing.SendCommand "(defun c:eo()(vl-vbarun ""arrangeent"")(princ))(princ)" & vbCr
TestLoad = True
End If
End Sub
哇,老大,你终于来了
1.端点是有,在监视窗口也可以看到,但就是不能通过line1.startpoint来应用.而定义为acadline时就可以.另外你这个再定义一个acadline的方法我也试过,不能这样赋值.
2.acadpolyline没有startpoint和endpoint.
3.谢谢. 1.除非你的软件有问题，不然这种定义方法是完全可行的。
为了试验可行性，看看在你的程序中在取得两条线后位置添加以下代码：
Dim l1 As AcadLine
Dim l2 As AcadLine
Set l1 = line1
Set l2 = line2
2.多段线只有顶点坐标，而没有起点和终点之说，可以使用以下两个方法：
Coordinate 指定对象中单个顶点的坐标。
Coordinates 指定对象中每个顶点的坐标。
3.你只使用斜率来判断线是否在同一直线是的条件好象少了，需要再加些条件。如果两条平行线怎么办？ 1.2.我再试试吧.明天晚上再汇报一下进展.
3.条件是不够,还在想其它办法. 1.可以了,我原来没用set
另外,acadpolyline,acadlwpolyline有什么不同？用vba画的在属性框看到的分别是2d/3d polyline 和 polyline ，在命令行用pl画的是polyline,好像2d/3d polyline是画不出的？
vba中能不能将多顶点polyline的某些顶点删除?
下面这个语句是不是错误?
if case1 then
dim line1 as acadline
else
dim line1 as acadlwpolyline
end if 没有必要删除顶点，用convert命令就可以将三维顶点的多段线改为二维多段线！ 以下是引用作者：mikewolf2k，发布时间：2004-1-19 19:59:19的帖子
下面这个语句是不是错误?
if case1 then
dim line1 as acadline
else
dim line1 as acadlwpolyline
end if
这样会造成编译错误：当前范围内声明重复。
我认为可以这样解决：
Dim Line1 As Variant
If case1 Then
ReDim Line1(0) As AcadLine
Else
ReDim Line1(0) As AcadLWPolyline
End If
其中，ReDim语句常用于改变数组大小或类型。因此，变量Line1先声明为变体，然后根据条件重新声明为长度为1的ACAD对象数组。 李版主的这个方法很好~~
页:
[1]