[VBA程序]：如何实现选择

qingshan

如何用程序实现操作CAD图纸放大缩小，自动选择整个图纸

Laoyao

2. 
   
3.   [FONT=courier new]
   
4. Sub SelAll()
   
5.     On Error Resume Next
   
6.     Dim mySel As AcadSelectionSet
   
7.    
   
8.     ThisDrawing.SelectionSets("tempSel").Delete
   
9.     Set mySel = ThisDrawing.SelectionSets.Add("tempSel")
   
10.    
    
11.     mySel.Select acSelectionSetAll
    
12.     mySel.Highlight True
    
13.    
    
14.         
    
15. End Sub
    
16. 
    
17. Sub Example_ZoomAll()
    
18.     ' This example creates several objects in model space and
    
19.     ' then performs a variety of zooms on the drawing.
    
20.    
    
21.     ' Create a Ray object in model space
    
22.     Dim rayObj As AcadRay
    
23.     Dim basePoint(0 To 2) As Double
    
24.     Dim SecondPoint(0 To 2) As Double
    
25.     basePoint(0) = 3#: basePoint(1) = 3#: basePoint(2) = 0#
    
26.     SecondPoint(0) = 1#: SecondPoint(1) = 3#: SecondPoint(2) = 0#
    
27.     Set rayObj = ThisDrawing.ModelSpace.AddRay(basePoint, SecondPoint)
    
28.    
    
29.     ' Create a polyline object in model space
    
30.     Dim plineObj As AcadLWPolyline
    
31.     Dim points(0 To 5) As Double
    
32.     points(0) = 3: points(1) = 7
    
33.     points(2) = 9: points(3) = 2
    
34.     points(4) = 3: points(5) = 5
    
35.     Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
    
36.     plineObj.Closed = True
    
37. 
    
38.     ' Create a line object in model space
    
39.     Dim lineObj As AcadLine
    
40.     Dim startPoint(0 To 2) As Double
    
41.     Dim endPoint(0 To 2) As Double
    
42.     startPoint(0) = 0: startPoint(1) = 0: startPoint(2) = 0
    
43.     endPoint(0) = 2: endPoint(1) = 2: endPoint(2) = 0
    
44.     Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
    
45.    
    
46.     ' Create a circle object in model space
    
47.     Dim circObj As AcadCircle
    
48.     Dim centerPt(0 To 2) As Double
    
49.     Dim radius As Double
    
50.     centerPt(0) = 20: centerPt(1) = 30: centerPt(2) = 0
    
51.     radius = 3
    
52.     Set circObj = ThisDrawing.ModelSpace.AddCircle(centerPt, radius)
    
53. 
    
54.     ' Create an ellipse object in model space
    
55.     Dim ellObj As AcadEllipse
    
56.     Dim majAxis(0 To 2) As Double
    
57.     Dim center(0 To 2) As Double
    
58.     Dim radRatio As Double
    
59.     center(0) = 5#: center(1) = 5#: center(2) = 0#
    
60.     majAxis(0) = 10: majAxis(1) = 20#: majAxis(2) = 0#
    
61.     radRatio = 0.3
    
62.     Set ellObj = ThisDrawing.ModelSpace.AddEllipse(center, majAxis, radRatio)
    
63. 
    
64. ' ZoomAll
    
65.     MsgBox "Perform a ZoomAll", , "ZoomWindow Example"
    
66.     ZoomAll
    
67.    
    
68. ' ZoomWindow
    
69.     MsgBox "Perform a ZoomWindow using the following coordinates:" & vbCrLf & _
    
70.            "1.3, 7.8, 0" & vbCrLf & _
    
71.            "13.7, -2.6, 0", , "ZoomWindow Example"
    
72.            
    
73.     Dim point1(0 To 2) As Double
    
74.     Dim point2(0 To 2) As Double
    
75.     point1(0) = 1.3: point1(1) = 7.8: point1(2) = 0
    
76.     point2(0) = 13.7: point2(1) = -2.6: point2(2) = 0
    
77.     ZoomWindow point1, point2
    
78.    
    
79. ' ZoomScaled
    
80.     MsgBox "Perform a ZoomScaled using:" & vbCrLf & _
    
81.            "Scale Type: acZoomScaledRelative" & vbCrLf & _
    
82.            "Scale Factor: 2", , "ZoomWindow Example"
    
83.     Dim scalefactor As Double
    
84.     Dim scaletype As Integer
    
85.     scalefactor = 2
    
86.     scaletype = acZoomScaledRelative
    
87.     ZoomScaled scalefactor, scaletype
    
88.    
    
89. ' ZoomExtents
    
90.     MsgBox "Perform a ZoomExtents", , "ZoomWindow Example"
    
91.     ZoomExtents
    
92.    
    
93. ' ZoomPickWindow
    
94.     MsgBox "Perform a ZoomPickWindow", , "ZoomWindow Example"
    
95.     ZoomPickWindow
    
96.    
    
97. ' ZoomCenter
    
98.     MsgBox "Perform a ZoomCenter using:" & vbCrLf & _
    
99.            "Center 3, 3, 0" & vbCrLf & _
    
100.            "Magnification: 10", , "ZoomWindow Example"
     
101.     Dim zcenter(0 To 2) As Double
     
102.     Dim magnification As Double
     
103.     zcenter(0) = 3: zcenter(1) = 3: zcenter(2) = 0
     
104.     magnification = 10
     
105.     ZoomCenter zcenter, magnification
     
106.    
     
107. End Sub
     
108. 
     
109. 
     
110.   [/FONT]
     

<br />   [FONT=courier new]<br /> Sub SelAll()<br />     On Error Resume Next<br />     Dim mySel As AcadSelectionSet<br />     <br />     ThisDrawing.SelectionSets("tempSel").Delete<br />     Set mySel = ThisDrawing.SelectionSets.Add("tempSel")<br />     <br />     mySel.Select acSelectionSetAll<br />     mySel.Highlight True<br />     <br />         <br /> End Sub<br /> <br /> Sub Example_ZoomAll()<br />     ' This example creates several objects in model space and<br />     ' then performs a variety of zooms on the drawing.<br />     <br />     ' Create a Ray object in model space<br />     Dim rayObj As AcadRay<br />     Dim basePoint(0 To 2) As Double<br />     Dim SecondPoint(0 To 2) As Double<br />     basePoint(0) = 3#: basePoint(1) = 3#: basePoint(2) = 0#<br />     SecondPoint(0) = 1#: SecondPoint(1) = 3#: SecondPoint(2) = 0#<br />     Set rayObj = ThisDrawing.ModelSpace.AddRay(basePoint, SecondPoint)<br />     <br />     ' Create a polyline object in model space<br />     Dim plineObj As AcadLWPolyline<br />     Dim points(0 To 5) As Double<br />     points(0) = 3: points(1) = 7<br />     points(2) = 9: points(3) = 2<br />     points(4) = 3: points(5) = 5<br />     Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)<br />     plineObj.Closed = True<br /> <br />     ' Create a line object in model space<br />     Dim lineObj As AcadLine<br />     Dim startPoint(0 To 2) As Double<br />     Dim endPoint(0 To 2) As Double<br />     startPoint(0) = 0: startPoint(1) = 0: startPoint(2) = 0<br />     endPoint(0) = 2: endPoint(1) = 2: endPoint(2) = 0<br />     Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)<br />     <br />     ' Create a circle object in model space<br />     Dim circObj As AcadCircle<br />     Dim centerPt(0 To 2) As Double<br />     Dim radius As Double<br />     centerPt(0) = 20: centerPt(1) = 30: centerPt(2) = 0<br />     radius = 3<br />     Set circObj = ThisDrawing.ModelSpace.AddCircle(centerPt, radius)<br /> <br />     ' Create an ellipse object in model space<br />     Dim ellObj As AcadEllipse<br />     Dim majAxis(0 To 2) As Double<br />     Dim center(0 To 2) As Double<br />     Dim radRatio As Double<br />     center(0) = 5#: center(1) = 5#: center(2) = 0#<br />     majAxis(0) = 10: majAxis(1) = 20#: majAxis(2) = 0#<br />     radRatio = 0.3<br />     Set ellObj = ThisDrawing.ModelSpace.AddEllipse(center, majAxis, radRatio)<br /> <br /> ' ZoomAll<br />     MsgBox "Perform a ZoomAll", , "ZoomWindow Example"<br />     ZoomAll<br />     <br /> ' ZoomWindow<br />     MsgBox "Perform a ZoomWindow using the following coordinates:" & vbCrLf & _<br />            "1.3, 7.8, 0" & vbCrLf & _<br />            "13.7, -2.6, 0", , "ZoomWindow Example"<br />            <br />     Dim point1(0 To 2) As Double<br />     Dim point2(0 To 2) As Double<br />     point1(0) = 1.3: point1(1) = 7.8: point1(2) = 0<br />     point2(0) = 13.7: point2(1) = -2.6: point2(2) = 0<br />     ZoomWindow point1, point2<br />     <br /> ' ZoomScaled<br />     MsgBox "Perform a ZoomScaled using:" & vbCrLf & _<br />            "Scale Type: acZoomScaledRelative" & vbCrLf & _<br />            "Scale Factor: 2", , "ZoomWindow Example"<br />     Dim scalefactor As Double<br />     Dim scaletype As Integer<br />     scalefactor = 2<br />     scaletype = acZoomScaledRelative<br />     ZoomScaled scalefactor, scaletype<br />     <br /> ' ZoomExtents<br />     MsgBox "Perform a ZoomExtents", , "ZoomWindow Example"<br />     ZoomExtents<br />     <br /> ' ZoomPickWindow<br />     MsgBox "Perform a ZoomPickWindow", , "ZoomWindow Example"<br />     ZoomPickWindow<br />     <br /> ' ZoomCenter<br />     MsgBox "Perform a ZoomCenter using:" & vbCrLf & _<br />            "Center 3, 3, 0" & vbCrLf & _<br />            "Magnification: 10", , "ZoomWindow Example"<br />     Dim zcenter(0 To 2) As Double<br />     Dim magnification As Double<br />     zcenter(0) = 3: zcenter(1) = 3: zcenter(2) = 0<br />     magnification = 10<br />     ZoomCenter zcenter, magnification<br />    <br /> End Sub<br /> <br /> <br />   [/FONT]<br />

ahlzl

Sub SelAll()
    On Error Resume Next
    Dim mySel As AcadSelectionSet
   
    ThisDrawing.SelectionSets("tempSel").Delete
    Set mySel = ThisDrawing.SelectionSets.Add("tempSel")
   
    mySel.Select acSelectionSetAll
    mySel.Highlight True        
End Sub

请Laoyao网友仔细讲讲“Hightlight”属性！我的英文太差了。

Laoyao

HELP原文。
Sets the highlight status for the given object, or for all objects in a given selection set。

设定所给OBJECT或SELECTIONSET中所有OBJECT为高亮模式（就是选中后的成为虚线状的样子:6 ）。
例
    ActiveDocument.ModelSpace.Item(1).Highlight True
   
    ActiveDocument.SelectionSets(1).Highlight True

ahlzl

最初由 Laoyao 发布
[B]HELP原文。
Sets the highlight status for the given object, or for all objects in a given selection set。

设定所给OBJECT或SELECTIONSET中所有OBJECT为高亮模式（就是选中后的成为虚线状的样子:6 ）。
例... [/B]

谢谢！
On Error Resume Next
Dim mySel As AcadSelectionSet

ThisDrawing.SelectionSets("tempSel").Delete
Set mySel = ThisDrawing.SelectionSets.Add("tempSel")
这几行写的比我的方法（见那个水库的贴子）好，又学一招！
再次感谢Laoyao，向Laoyao学习！！！

efan2000

在程序中应该尽量少用On Error Resume Next,因为它有可能屏蔽之后产生的错误,使调试因难.
好的方法是先遍历整个选择集,如果选择集不存在,那么就创建一个.
当然如果这种方法繁杂的话,也可以单独编写一个过程或者函数来设置选择集.而在这段代码中加入错误处理机制,尽量避免将错误带到代码外的语句.

chenzl230618

经验之谈，可以解决很多没名的错误

cityplan

有时候ON ERROR不是很有用的，可以省不少源程序！

god

不过如果VB中不用on error ，又是发生错误时就突然退出了，用了代码又大大增加了，每个sub都要加一段错误陷阱代码。

谁有什么好办法吗？能省点代码的。方便好用的。

秋枫

关于选择的操作，我转贴几个例程：（转自明经通道 ）

2. 
   
3. [FONT=courier new]
   
4. ' 不断提示选择一个对象直到获取了对象或用户取消操作
   
5. Public Sub GetEntityEx(ent As Object, pickedPoint, Optional Prompt)
   
6. 
   
7.     On Error Resume Next
   
8. StartLoop:
   
9.     acadApp.ActiveDocument.Utility.GetEntity ent, pt, Prompt
   
10.     If Err Then
    
11.         If acadApp.ActiveDocument.GetVariable("errno") = 7 Then
    
12.             Err.Clear
    
13.             GoTo StartLoop
    
14.         Else
    
15. 
    
16.             Err.Raise vbObjectError + 5, , "用户取消操作"
    
17.         End If
    
18.     End If
    
19. 
    
20. End Sub
    
21. 
    
22. 
    
23. ' 返回一个空白选择集
    
24. ' 它也可消除烦人的“选择集已经存在”问题
    
25. 
    
26. Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet
    
27. 
    
28.     Dim ss As AcadSelectionSet
    
29.    
    
30.     On Error Resume Next
    
31.     Set ss = ThisDrawing.SelectionSets(ssName)
    
32.     If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
    
33.     ss.Clear
    
34.     Set CreateSelectionSet = ss
    
35. 
    
36. End Function
    
37. 
    
38. ' 对象选择，可实现先选择后操作和先操作后选择
    
39. ' 作者：郑立楷
    
40. Function GetSelSet() As AcadSelectionSet
    
41.     Dim ss As AcadSelectionSet
    
42.     Dim ssName As String
    
43.     ssName = "PICKFIRST"
    
44.     On Error Resume Next
    
45.     Set ss = ThisDrawing.SelectionSets.Add(ssName)
    
46.     If Err Then
    
47.         Set ss = ThisDrawing.SelectionSets(ssName)
    
48.         ss.Delete
    
49.     End If
    
50.     Set ss = ThisDrawing.PickfirstSelectionSet
    
51.     If ss.Count = 0 Then
    
52.         Set ss = ThisDrawing.SelectionSets(ssName)
    
53.         If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
    
54.         ss.Clear
    
55.         ss.SelectOnScreen
    
56.     End If
    
57.     Set GetSelSet = ss
    
58. End Function
    
59. 
    
60. 
    
61. [/FONT]

<br /> [FONT=courier new]<br /> ' 不断提示选择一个对象直到获取了对象或用户取消操作 <br /> Public Sub GetEntityEx(ent As Object, pickedPoint, Optional Prompt)<br /> <br />     On Error Resume Next<br /> StartLoop:<br />     acadApp.ActiveDocument.Utility.GetEntity ent, pt, Prompt<br />     If Err Then<br />         If acadApp.ActiveDocument.GetVariable("errno") = 7 Then<br />             Err.Clear<br />             GoTo StartLoop<br />         Else<br /> <br />             Err.Raise vbObjectError + 5, , "用户取消操作"<br />         End If<br />     End If<br /> <br /> End Sub <br /> <br /> <br /> ' 返回一个空白选择集<br /> ' 它也可消除烦人的“选择集已经存在”问题<br /> <br /> Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet<br /> <br />     Dim ss As AcadSelectionSet<br />     <br />     On Error Resume Next<br />     Set ss = ThisDrawing.SelectionSets(ssName)<br />     If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)<br />     ss.Clear<br />     Set CreateSelectionSet = ss<br /> <br /> End Function<br /> <br /> ' 对象选择，可实现先选择后操作和先操作后选择 <br /> ' 作者：郑立楷<br /> Function GetSelSet() As AcadSelectionSet<br />     Dim ss As AcadSelectionSet<br />     Dim ssName As String<br />     ssName = "PICKFIRST"<br />     On Error Resume Next<br />     Set ss = ThisDrawing.SelectionSets.Add(ssName)<br />     If Err Then<br />         Set ss = ThisDrawing.SelectionSets(ssName)<br />         ss.Delete<br />     End If<br />     Set ss = ThisDrawing.PickfirstSelectionSet<br />     If ss.Count = 0 Then<br />         Set ss = ThisDrawing.SelectionSets(ssName)<br />         If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)<br />         ss.Clear<br />         ss.SelectOnScreen<br />     End If<br />     Set GetSelSet = ss<br /> End Function <br /> <br /> <br /> [/FONT]