VBA怎样删除重复的圆？

taqqug

弱弱的问一下大家，CAD中怎样用VBA标记出有重复的圆，并提示删掉？我现在用选择集选择了所有的圆，想用圆心相等来判断（还得半径相等），可是圆心不让比较，请大家帮忙，最好给出代码，谢谢啦！！

sealive_leafage

+ ?3 _5 f/ I( Z# j
! N5 }% ~" C1 }circle对象的center属性返回的是一维三元素数组，0代表圆心的x坐标，1代表圆心的y坐标，2代表圆心的z坐标，可以分别通过比较x、y、z坐标判断圆心是否相同，注意控制坐标值的对比位数；
circle对象的center属性示例代码如下：
Sub Example_Center()        
3 V  }! p( R8 F6 RDim circObj As AcadCircle   
Dim currCenterPt(0 To 2) As Double   
) U) y  H3 ]' u: ~Dim newCenterPt(0 To 2) As Double   
Dim radius As Double        
' Define the initial center point and radius for the circle   
currCenterPt(0) = 20: currCenterPt(1) = 30: currCenterPt(2) = 0   
8 H5 M9 ~2 e- Yradius = 3        
9 R, z) ?0 U" l: A' [5 o' Create the circle in model space   
( i* R# n* I* D0 D0 XSet circObj = ThisDrawing.ModelSpace.AddCircle(currCenterPt, radius)   
+ ~. U7 w1 \' B2 w& TZoomAll   
MsgBox "The center point of the circle is " & currCenterPt(0) & ", " & currCenterPt(1) & ", " & currCenterPt(2),vbInformation, "Center Example"   
  [- A# ~& j3 u* J: h) u' Change the center point of the circle   
/ ?# ]$ \) h$ a* V4 YnewCenterPt(0) = 25: newCenterPt(1) = 25: newCenterPt(2) = 0   
circObj.center = newCenterPt   
6 ~' {# ]4 Q/ X( V% X8 w  RcircObj.Update        
' Query the results of the new center position   
' Notice the output from the center property is a variant   
3 u& r% R2 @0 i/ p+ G2 cDim centerPoint As Variant   
0 m- ]; L4 n$ J5 f: bcenterPoint = circObj.center   
) Q* h! ]* ^& T9 X& ]MsgBox "The center point of the circle is " & centerPoint(0) & ", " & centerPoint(1) & ", " & centerPoint(2),vbInformation, "Center Example"
End Sub

woaishuijia

圆心(点)是数组,得分别比较三个坐标才行.

1. 
   0 r' o, x* m  ?4 Z9 a* g
2.     Dim SS As AcadSelectionSet, FT(0) As Integer, FD(0) As Variant, C1 As AcadCircle, C2 As AcadCircle, I As Long, J As Long
   
3.     FT(0) = 0: FD(0) = "Circle"
   6 u9 b. G3 ?; Q8 S  Q+ i
4.     Set SS = ThisDrawing.SelectionSets.Add("SS")
   
5.     SS.Select acSelectionSetAll, , , FT, FD
   % A+ D8 W: N; h6 |
6.     If SS.Count > 1 Then
   # `8 G. d$ q8 i% w) p" n$ Y7 w. ?
7.         For I = SS.Count - 1 To 1 Step -1
   1 Z3 [. `1 u6 _; r. U! V. p
8.             Set C1 = SS.Item(I)
   
9.             For J = I - 1 To 0 Step -1
   ! r$ o& r4 Q3 Z0 ^# B
10.                 Set C2 = SS.Item(J)
    
11.                 If C1.Center(0) = C2.Center(0) And C1.Center(1) = C2.Center(1) And C1.Center(2) = C2.Center(2) And C1.Radius = C2.Radius Then
    $ U( E( Z* @# W! {% n9 f( c
12.                     C1.Delete
    ) a5 O/ D3 R0 z
13.                     Exit For
    & D9 D5 f+ [! s, G( |1 F
14.                 End If
    
15.             Next
    + {' B: b! m) |
16.         Next
    
17.     End If
    
18.     SS.Delete
    5 @. ~& ]4 q1 @/ Y1 k; L# q2 p

复制代码

taqqug

豁然开朗，我知道我错哪了，谢谢大家了！

cone521

我也在学习中，谢谢楼主

3duser

如果好了的话楼主将怎样删除线的命令一起研发下吧

www1974

如果好了的话楼主将怎样删除线的命令一起研发下吧
3duser 发表于 2010-10-4 20:33 http://www.3dportal.cn/discuz/images/common/back.gif

" ?& |: z, Q3 K! T$ L安装ET工具，输入overkill即可