好像多数高手们都回家了,请教一个问题

mikewolf2k · 发表于 2004-1-18 19:53:00

先祝各位早年愉快!
我想做一个将同一直线上的两条线段合并的程序,基本思路如下:
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)

mccad · 发表于 2004-1-18 21:27:00

1.只要图元是直线，就有StartPoint和EndPoint属性，不论其定义为AcadEntity或AcadLine，你也可以在
If line2.ObjectName = "AcDbLine" Then
后增加
Dim Line_2 as AcadLine
Set Line_2 = line2
来定义。
2.判断多段线的类型，可以使用多段线的Type属性，只有其值为acSimplePoly才为一般的多段线。
3.呵呵，你只要增加以下代码就行，利用的是EndCommand事件,看看我在那个程序中的源码吧：

copy


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

mikewolf2k · 发表于 2004-1-18 21:36:00

哇,老大,你终于来了
1.端点是有,在监视窗口也可以看到,但就是不能通过line1.startpoint来应用.而定义为acadline时就可以.另外你这个再定义一个acadline的方法我也试过,不能这样赋值.
2.acadpolyline没有startpoint和endpoint.
3.谢谢.

mccad · 发表于 2004-1-18 21:44:00

1.除非你的软件有问题，不然这种定义方法是完全可行的。
为了试验可行性，看看在你的程序中在取得两条线后位置添加以下代码：
Dim l1 As AcadLine
Dim l2 As AcadLine
Set l1 = line1
Set l2 = line2
2.多段线只有顶点坐标，而没有起点和终点之说，可以使用以下两个方法：
Coordinate 指定对象中单个顶点的坐标。
Coordinates 指定对象中每个顶点的坐标。
3.你只使用斜率来判断线是否在同一直线是的条件好象少了，需要再加些条件。如果两条平行线怎么办？

mikewolf2k · 发表于 2004-1-18 21:48:00

1.2.我再试试吧.明天晚上再汇报一下进展.
3.条件是不够,还在想其它办法.

mikewolf2k · 发表于 2004-1-19 19:59:00

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

myfreemind · 发表于 2004-1-19 20:20:00

没有必要删除顶点，用convert命令就可以将三维顶点的多段线改为二维多段线！

leeyeafu · 发表于 2004-1-20 08:20:00

这样会造成编译错误：当前范围内声明重复。
我认为可以这样解决：
Dim Line1 As Variant
If case1 Then
ReDim Line1(0) As AcadLine
Else
ReDim Line1(0) As AcadLWPolyline
End If
其中，ReDim语句常用于改变数组大小或类型。因此，变量Line1先声明为变体，然后根据条件重新声明为长度为1的ACAD对象数组。

myfreemind · 发表于 2004-1-23 14:42:00

李版主的这个方法很好~~

好像多数高手们都回家了,请教一个问题

发表回复

精选推荐

浏览过的版块