VBA怎样删除重复的圆？

taqqug

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

sealive_leafage

1 x1 ^; Y; f9 f2 c1 @5 R. qcircle对象的center属性返回的是一维三元素数组，0代表圆心的x坐标，1代表圆心的y坐标，2代表圆心的z坐标，可以分别通过比较x、y、z坐标判断圆心是否相同，注意控制坐标值的对比位数；
8 e& C$ P) d+ H" Y, [% Wcircle对象的center属性示例代码如下：
0 B6 J5 c! C: K7 P$ C! r1 Q" TSub Example_Center()        
" h; D& n" q& YDim circObj As AcadCircle   
1 a6 J2 V6 h8 T+ rDim currCenterPt(0 To 2) As Double   
" U3 r' a0 O  C: ?0 w% X2 pDim newCenterPt(0 To 2) As Double   
/ ^" I- X' H/ V9 p: K& q' TDim radius As Double        
' Define the initial center point and radius for the circle   
% i5 c6 j6 Y8 }5 q7 `currCenterPt(0) = 20: currCenterPt(1) = 30: currCenterPt(2) = 0   
$ c7 K" L# T- l1 A/ Eradius = 3        
  F3 q. F6 ?0 k0 V& c+ P! d6 A' Create the circle in model space   
5 ~" Z2 L8 r8 CSet circObj = ThisDrawing.ModelSpace.AddCircle(currCenterPt, radius)   
! O' ^* v4 I' b! W# iZoomAll   
MsgBox "The center point of the circle is " & currCenterPt(0) & ", " & currCenterPt(1) & ", " & currCenterPt(2),vbInformation, "Center Example"   
8 u: Q# R  Y5 O& r2 S' Change the center point of the circle   
newCenterPt(0) = 25: newCenterPt(1) = 25: newCenterPt(2) = 0   
% \" ^: b& [- T! fcircObj.center = newCenterPt   
  k' K& K* W$ X1 U4 Q- h$ PcircObj.Update        
* O) H( H5 N2 f/ Y' Query the results of the new center position   
$ L! _0 P0 n2 p$ P6 ~% k' Notice the output from the center property is a variant   
+ e$ \/ }  j( t% _9 ADim centerPoint As Variant   
centerPoint = circObj.center   
MsgBox "The center point of the circle is " & centerPoint(0) & ", " & centerPoint(1) & ", " & centerPoint(2),vbInformation, "Center Example"
End 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
   
3.     FT(0) = 0: FD(0) = "Circle"
   
4.     Set SS = ThisDrawing.SelectionSets.Add("SS")
   
5.     SS.Select acSelectionSetAll, , , FT, FD
   9 t5 d* l# D1 L& \
6.     If SS.Count > 1 Then
   
7.         For I = SS.Count - 1 To 1 Step -1
   " _( P" s% @4 d
8.             Set C1 = SS.Item(I)
   0 B, X" T# {& L
9.             For J = I - 1 To 0 Step -1
   / c6 ]1 k4 u2 ?! ^
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
    - k1 Y  G/ U- A% d7 q/ [% z1 i
12.                     C1.Delete
    * x) x2 L4 k/ b0 |8 |  o
13.                     Exit For
    
14.                 End If
    
15.             Next
    " {3 d+ p- U* w* u; J$ h1 I
16.         Next
    : \* Y4 Y4 h3 I, q$ `
17.     End If
    
18.     SS.Delete
    

复制代码

taqqug

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

cone521

我也在学习中，谢谢楼主

3duser

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

www1974

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

) Z/ H4 s" T! X8 k8 F4 ~6 M安装ET工具，输入overkill即可