VBA怎样删除重复的圆？

taqqug

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

sealive_leafage

8 H; S8 Z3 ]  z7 h
0 S9 b4 f8 q2 t! l' _circle对象的center属性返回的是一维三元素数组，0代表圆心的x坐标，1代表圆心的y坐标，2代表圆心的z坐标，可以分别通过比较x、y、z坐标判断圆心是否相同，注意控制坐标值的对比位数；
circle对象的center属性示例代码如下：
5 Q1 N9 @5 O9 NSub Example_Center()        
, |* y' f6 w" Y8 {: ]* k* yDim circObj As AcadCircle   
Dim currCenterPt(0 To 2) As Double   
7 ^, Z5 o+ {0 B( f0 o& a5 aDim newCenterPt(0 To 2) As Double   
; ]0 r" ^) R8 f$ u+ CDim radius As Double        
4 I0 a- b5 {- Z3 k+ c' Define the initial center point and radius for the circle   
currCenterPt(0) = 20: currCenterPt(1) = 30: currCenterPt(2) = 0   
+ Y& `2 l; Y3 O" I+ L4 |/ d* y8 ]radius = 3        
& r8 ]% Y- T. L8 c. W' Create the circle in model space   
& V# V  {* }- H/ c! pSet circObj = ThisDrawing.ModelSpace.AddCircle(currCenterPt, radius)   
ZoomAll   
+ G: y1 W1 T  k# xMsgBox "The center point of the circle is " & currCenterPt(0) & ", " & currCenterPt(1) & ", " & currCenterPt(2),vbInformation, "Center Example"   
' Change the center point of the circle   
newCenterPt(0) = 25: newCenterPt(1) = 25: newCenterPt(2) = 0   
' \- ^) _) J' X  m2 u3 G2 T8 a; CcircObj.center = newCenterPt   
circObj.Update        
' Query the results of the new center position   
' l9 _4 l6 g' j' e' Notice the output from the center property is a variant   
Dim centerPoint As Variant   
centerPoint = circObj.center   
0 z1 W  ~0 ~5 k" E8 I: \MsgBox "The center point of the circle is " & centerPoint(0) & ", " & centerPoint(1) & ", " & centerPoint(2),vbInformation, "Center Example"
. Q3 j6 `1 `8 |. |4 A0 XEnd Sub

woaishuijia

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

1. 
   
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
   ' `7 W6 W- F* U2 S8 s1 O, ~5 {  m
3.     FT(0) = 0: FD(0) = "Circle"
   
4.     Set SS = ThisDrawing.SelectionSets.Add("SS")
   
5.     SS.Select acSelectionSetAll, , , FT, FD
   
6.     If SS.Count > 1 Then
   7 I) T4 v4 G# k
7.         For I = SS.Count - 1 To 1 Step -1
   7 R" \! \5 @7 T, m
8.             Set C1 = SS.Item(I)
   
9.             For J = I - 1 To 0 Step -1
   ) w- a, q1 u  ~: [8 w
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
    
12.                     C1.Delete
    5 ~8 E$ R7 a0 i7 n0 ~" @  X
13.                     Exit For
    
14.                 End If
    ' ?; K& V- d0 G9 e  U0 o0 C
15.             Next
    
16.         Next
      m0 ^0 c3 l+ A: g; V' s" u. e& X
17.     End If
    # l4 i5 p  E' J5 q
18.     SS.Delete
    * o! t2 |# s' \

复制代码

taqqug

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

cone521

我也在学习中，谢谢楼主

3duser

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

www1974

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

安装ET工具，输入overkill即可