谁可以帮我（关于VBA在CAD 中的选择集的使用）

wdxbf

我最近在做毕业设计时，有点麻烦，不知那位大侠可以帮我。我将不胜感谢。


         我在用cad中自带的vba编程序时，定义的选择集，可在不知为什么就是不能选择对象，我对选择集中的对象做镜像，第一遍运行根本没反应，可如果再运行一边，就会镜像出另一半，这是怎么回事？（我用的是CAD2004中文版）。


                 我附上 我的程序原文件，望指点。谢谢

mccad

第一次定义的选择集没有做清空，所以第二次运行时就连第一次的选择集都用上了。

wdxbf

不是没有清空，而是定义之后，选择集是空的，我用F8单步运行，一直显示是空的，选择后还是空的，不知为什么？

mccad

2. Sub mi()
3.        Dim ss As AcadSelectionSet
4.        On Error Resume Next
5.        ThisDrawing.SelectionSets("mccad").Delete
6.        Set ss = ThisDrawing.SelectionSets.Add("mccad")
7.          
8.        ThisDrawing.Utility.Prompt vbCr & "请选择镜像的对象："
9.        ss.SelectOnScreen
10.       
11.        Dim pnt1, pnt2
12.        pnt1 = ThisDrawing.Utility.GetPoint(, vbCr & "指定镜像线的第一点：")
13.        pnt2 = ThisDrawing.Utility.GetPoint(pnt1, vbCr & "指定镜像线的第二点：")
14.       
15.        Dim ent As AcadEntity
16.        If ss.Count > 0 Then
17.                For Each ent In ss
18.                        ent.Mirror pnt1, pnt2
19.                Next
20.        End If
21.       
22. End Sub

Sub mi()        Dim ss As AcadSelectionSet        On Error Resume Next        ThisDrawing.SelectionSets("mccad").Delete        Set ss = ThisDrawing.SelectionSets.Add("mccad")                  ThisDrawing.Utility.Prompt vbCr & "请选择镜像的对象："        ss.SelectOnScreen               Dim pnt1, pnt2        pnt1 = ThisDrawing.Utility.GetPoint(, vbCr & "指定镜像线的第一点：")        pnt2 = ThisDrawing.Utility.GetPoint(pnt1, vbCr & "指定镜像线的第二点：")               Dim ent As AcadEntity        If ss.Count > 0 Then                For Each ent In ss                        ent.Mirror pnt1, pnt2                Next        End If        End Sub

wdxbf

谢谢你的回复, 我用的是全部由程序自己进行, 所以上面的方法还是不可用.


         我是买了 您出的<< AutoCAD2004 VBA精彩开发实例 >>自学的.


                 好多东西我还是不太明白,         我是设计了一个界面,然后在其中控件的代码中添加了所有程序, 我单步运行过程中,图形上无法显示已经用命令画的线, 在运行到定义的选择集时,创建成功,可是选择后,还是空,         有的我改变了 过滤参数的名称后,如果再运行一边,可以镜相出来,可如果不该,就不行了,不知道为什么?


                         我想把原代码 给您发E-mail中,还望您能指点.         

mccad

E过来吧，没有代码，靠说是说不清楚的。

mccad

对于程序生成的对象，在对象生成的时候就可以取得对象，而不需要再经过选择集来选定。如你程序中绘制活塞图中的一段就可以这样写：
   

2. '画图
3.      Dim varLines(20) As AcadEntity
4.        Set varLines(0) = AddLine(ImPoint(0), ImPoint(1))
5.        Set varLines(1) = AddLine(ImPoint(1), ImPoint(2))
6.        Set varLines(2) = AddLine(ImPoint(2), ImPoint(3))
7.        Set varLines(3) = AddLine(ImPoint(3), ImPoint(4))
8.        Set varLines(4) = AddLine(ImPoint(4), ImPoint(5))
9.        Set varLines(5) = AddLine(ImPoint(5), ImPoint(6))
10.        Set varLines(6) = AddLine(ImPoint(6), ImPoint(7))
11.        Set varLines(7) = AddLine(ImPoint(7), ImPoint(8))
12.        Set varLines(8) = AddLine(ImPoint(8), ImPoint(9))
13.        Set varLines(9) = AddLine(ImPoint(9), ImPoint(10))
14.        Set varLines(10) = AddLine(ImPoint(10), ImPoint(11))
15.        Set varLines(11) = AddLine(ImPoint(11), ImPoint(12))
16.        Set varLines(12) = AddLine(ImPoint(15), ImPoint(14))
17.        Set varLines(13) = AddLine(ImPoint(13), ImPoint(15))
18.        Set varLines(14) = AddLine(ImPoint(15), ImPoint(17))
19.        Set varLines(15) = AddLine(ImPoint(16), ImPoint(17))
20.        Set varLines(16) = AddLine(ImPoint(17), ImPoint(18))
21.        Set varLines(17) = AddLine(ImPoint(10), ImPoint(19))
22.        Set varLines(18) = AddLine(ImPoint(19), ImPoint(20))
23.        Set varLines(19) = AddLine(ImPoint(20), ImPoint(21))
24.    '切换到虚线 图层
25.            For Each objLayer In ThisDrawing.Layers
26.              If objLayer.name = "虚线" Then
27.                ThisDrawing.ActiveLayer = objLayer
28.              End If
29.            Next
30.          Set varLines(20) = AddLine(ImPoint(13), ImPoint(18))
31.    '切换到0 图层
32.            For Each objLayer In ThisDrawing.Layers
33.              If objLayer.name = "0" Then
34.                ThisDrawing.ActiveLayer = objLayer
35.              End If
36.            Next
37.       
38. ' 镜像
39.        Dim i As Integer
40.        For i = 0 To 20
41.                varLines(i).Mirror ImPoint(0), ImPoint(12)
42.        Next i
43.        End

'画图      Dim varLines(20) As AcadEntity        Set varLines(0) = AddLine(ImPoint(0), ImPoint(1))        Set varLines(1) = AddLine(ImPoint(1), ImPoint(2))        Set varLines(2) = AddLine(ImPoint(2), ImPoint(3))        Set varLines(3) = AddLine(ImPoint(3), ImPoint(4))        Set varLines(4) = AddLine(ImPoint(4), ImPoint(5))        Set varLines(5) = AddLine(ImPoint(5), ImPoint(6))        Set varLines(6) = AddLine(ImPoint(6), ImPoint(7))        Set varLines(7) = AddLine(ImPoint(7), ImPoint(8))        Set varLines(8) = AddLine(ImPoint(8), ImPoint(9))        Set varLines(9) = AddLine(ImPoint(9), ImPoint(10))        Set varLines(10) = AddLine(ImPoint(10), ImPoint(11))        Set varLines(11) = AddLine(ImPoint(11), ImPoint(12))        Set varLines(12) = AddLine(ImPoint(15), ImPoint(14))        Set varLines(13) = AddLine(ImPoint(13), ImPoint(15))        Set varLines(14) = AddLine(ImPoint(15), ImPoint(17))        Set varLines(15) = AddLine(ImPoint(16), ImPoint(17))        Set varLines(16) = AddLine(ImPoint(17), ImPoint(18))        Set varLines(17) = AddLine(ImPoint(10), ImPoint(19))        Set varLines(18) = AddLine(ImPoint(19), ImPoint(20))        Set varLines(19) = AddLine(ImPoint(20), ImPoint(21))    '切换到虚线 图层            For Each objLayer In ThisDrawing.Layers              If objLayer.name = "虚线" Then                ThisDrawing.ActiveLayer = objLayer              End If            Next          Set varLines(20) = AddLine(ImPoint(13), ImPoint(18))    '切换到0 图层            For Each objLayer In ThisDrawing.Layers              If objLayer.name = "0" Then                ThisDrawing.ActiveLayer = objLayer              End If            Next        ' 镜像        Dim i As Integer        For i = 0 To 20                varLines(i).Mirror ImPoint(0), ImPoint(12)        Next i        End

可以看到，这里用了一个varLine数组来保存生成的直线，这样在最后就可以使用该数组来镜像这样对象。
另外，你的程序好多是重复的内容，如生成图框其它都是一样，只是名称不同，所以将其做为一个函数最好，不然这样给人感觉很乱。

wdxbf

真不知道怎么感谢您,我为这个问题,整整忙了两周,我都快放弃了, 学校老师没有人懂这方面 .         真是非常感谢


                                 可以告诉我,您一般什么时候在线吗?         我的毕业设计需要您的指点.