[求助]请高手帮我改改这个程序
本帖最后由 作者 于 2005-4-21 22:11:25 编辑 <br /><br /> Sub example_aaa()<BR> On Error Resume Next<BR> <BR> Dim myss As AcadSelectionSet<BR> If Not IsNull(ThisDrawing.SelectionSets.Item("myss")) Then<BR> Set myss = ThisDrawing.SelectionSets.Item("myss")<BR> myss.detele<BR> End If<BR> <BR> Set myss = ThisDrawing.SelectionSets.Add("myss")<BR> <BR> Dim mode As Integer<BR> mode = acSelectionSetAll<BR> myss.Select mode<BR> <BR> Dim layerobj As AcadLayer<BR> Set layerobj = ThisDrawing.Layers.Add("new")<BR> layerobj.color = acRed<BR> <BR> <BR> <BR> <BR> Dim returnobj As Object<BR> Dim returnpnt As Variant<BR> <BR> Dim re As Variant<BR> ThisDrawing.Utility.GetEntity returnobj, returnpnt, "选择图像:"<BR> MsgBox myss.count<BR> <BR> Dim StartPoint, EndPoint<BR> StartPoint = returnobj.StartPoint<BR> EndPoint = returnobj.EndPoint<BR> <BR> MsgBox "起点 " & StartPoint(0) & "," & StartPoint(1) & "," & StartPoint(2) & " 终点 " & EndPoint(0) & "," & EndPoint(1) & "," & EndPoint(2) & " name " & returnobj.ObjectName & " ID " & returnobj.ObjectID<BR> returnobj.Layer = "new"<BR> returnobj.Update<BR> Dim rees(0) As AcadEntity<BR> Set rees(0) = returnobj<BR> myss.RemoveItems rees<BR> MsgBox myss.count<BR>GoSub sts<BR> myss.Delete<BR>Exit Sub<BR>sts:<BR> Dim k As Integer<BR> Dim i As Double<BR> Dim j As Double<BR> Dim count As Integer<BR> count = ThisDrawing.SelectionSets.myss.count<BR> ReDim mysss(count - 1) As AcadEntity<BR> For k = 0 To myss.count - 1<BR> Set mysss(k) = ThisDrawing.SelectionSets.myss.Item(k)<BR> StartPoint = myss.Item(k).StartPoint<BR> EndPoint = myss.Item(k).EndPoint<BR> i = 3<BR> j = 0<BR> If StartPoint(i) = StartPoint(j) And StartPoint(i + 1) = StartPoint(j + 1) And StartPoint(i + 2) = StartPoint(j + 2) Then<BR> MsgBox "坐标起点" & EndPoint(j) & "," & EndPoint(j + 1) & "," & EndPoint(j + 2) & "终点" & StartPoint(j) & "," & StartPoint(j + 1) & "," & StartPoint(j + 2) & " name " & myss.Item(k).ObjectName & " ID " & myss.Item(k).ObjectID<BR> myss.Item(k).Layer = "new"<BR> i = i + 3<BR> j = j + 3<BR> myss.RemoveItems mysss<BR> MsgBox myss.count<BR> ElseIf EndPoint(i) = StartPoint(j) And EndPoint(i + 1) = StartPoint(j + 1) And EndPoint(i + 2) = StartPoint(j + 2) Then<BR> MsgBox "坐标起点" & EndPoint(j) & "," & EndPoint(j + 1) & "," & EndPoint(j + 2) & "终点" & StartPoint(j) & "," & StartPoint(j + 1) & "," & StartPoint(j + 2) & " name " & myss.Item(k).ObjectName & " ID " & myss.Item(k).ObjectID<BR> i = i + 3<BR> j = j + 3<BR> myss.Item(k).Layer = "new"<BR> myss.RemoveItems mysss<BR> <BR> MsgBox myss.count<BR> Else: MsgBox "no object"<BR> <BR> <BR> <BR> End If<BR> <BR> Next<BR> <BR> Return<BR>End Sub
要求：在一个封闭的图形中选择一个object，得出端点坐标，然后根据一端端点坐标得出相连object的两个端点坐标，直到得到封闭图像的所有object的端点坐标。（其实就是安一定方向得到端点坐标）
不知道为什么运行的不是按顺序得出端点坐标，请帮忙改一改。或者希望能够提出一个更好的按顺序得出端点坐标的方法。
页:
[1]