请斑竹过来看看,重复点程序有无问题?请指教!
<P>Sub delchongfupoint()<BR>Dim entity As AcadPoint<BR>Dim xyz As Variant<BR>Dim i As Double<BR>Dim j As Double<BR>Dim counter As Integer<BR>Dim ftype(0 To 1) As Integer<BR>Dim fdata(0 To 1) As Variant<BR>Dim sset As AcadSelectionSet<BR>'初始颜色是acwhite；扫描过的颜色是acblue；重合点的颜色是acred<BR>If ThisDrawing.ModelSpace.Count <> 0 Then<BR> i = ThisDrawing.ModelSpace.Count<BR>'先循环一下，初始化设置所有的颜色为acwhite,如果已知颜色的话是不需要做的<BR> For j = 0 To i - 1<BR> Set entity = ThisDrawing.ModelSpace.Item(j)<BR> entity.Color = acWhite<BR> Next j<BR> For j = 0 To i - 1<BR> Set entity = ThisDrawing.ModelSpace.Item(j)<BR> xyz = entity.Coordinates '取得点的坐标<BR>'判断图形中是否已经存在同名的选择集<BR> On Error Resume Next<BR> If Not IsNull(ThisDrawing.SelectionSets.Item("sset")) Then<BR> Set sset = ThisDrawing.SelectionSets.Item("sset")<BR> sset.Delete '及时删除不用的选择集非常重要<BR> End If<BR>'创建新选择集<BR> Set sset = ThisDrawing.SelectionSets.Add("sset")<BR> If Err Then Set sset = ThisDrawing.SelectionSets.Add("sset")<BR> sset.Clear<BR>'指定过滤机制<BR> ftype(0) = 0: fdata(0) = "point"<BR> ftype(1) = 8: fdata(1) = "*" '图层名<BR>'使用crossing的选择模式<BR> sset.Select acSelectionSetCrossing, xyz, xyz, ftype, fdata<BR> Dim obj As AcadPoint<BR> For Each obj In sset<BR> If obj.Color = acBlue Then<BR> obj.Color = acRed<BR> End If<BR> If obj.Color = acWhite Then<BR> obj.Color = acBlue<BR> End If<BR> Next<BR> Next j<BR>MsgBox "描点结束！"<BR>Else<BR>MsgBox "在模型空间中没有对象存在。"<BR>End If<BR>End Sub</P><P>'请教斑竹,我用acSelectionSetCrossing时,不是只选择这个xyz上的点吗,但是程序运行,有的时候它旁边的点也变红,不知道是怎么回事,请指教!</P>
<P>这是我根据买你的VBA书写的,请赐教!</P> <P>cad用点来选择是不准的!</P> <P>那么怎么根据一个坐标，将这个坐标上所有的点能选中呢？</P>
页:
[1]