VBA怎样删除重复的圆？

taqqug

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

sealive_leafage

# e' S; j; a+ U6 K3 kcircle对象的center属性返回的是一维三元素数组，0代表圆心的x坐标，1代表圆心的y坐标，2代表圆心的z坐标，可以分别通过比较x、y、z坐标判断圆心是否相同，注意控制坐标值的对比位数；
circle对象的center属性示例代码如下：
; w" Q2 }& b8 A1 M% W! hSub Example_Center()        
Dim circObj As AcadCircle   
Dim currCenterPt(0 To 2) As Double   
+ |7 u1 x' P3 [Dim newCenterPt(0 To 2) As Double   
Dim radius As Double        
9 S! i; w: q& [- ]( u, R* L8 b2 i' Define the initial center point and radius for the circle   
currCenterPt(0) = 20: currCenterPt(1) = 30: currCenterPt(2) = 0   
radius = 3        
' Create the circle in model space   
' p1 z( P' A5 X8 ?9 p. t: WSet circObj = ThisDrawing.ModelSpace.AddCircle(currCenterPt, radius)   
: k" d0 A- O$ R6 D6 S- K' a# `ZoomAll   
MsgBox "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   
' E$ z6 |; N" _) Y: lcircObj.center = newCenterPt   
! _" O+ @' O) e- j$ kcircObj.Update        
7 A1 N6 e( Z; n' Query the results of the new center position   
- P* P9 s' Z: A' |  n$ ?* E  f/ Y' Notice the output from the center property is a variant   
  t1 e# r5 a) a6 ~  J# |Dim centerPoint As Variant   
centerPoint = circObj.center   
MsgBox "The center point of the circle is " & centerPoint(0) & ", " & centerPoint(1) & ", " & centerPoint(2),vbInformation, "Center Example"
: O/ q: i/ k* w8 V  s7 T2 E6 ^  w5 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
   " U# E( O8 L% b* b; f! z
3.     FT(0) = 0: FD(0) = "Circle"
   
4.     Set SS = ThisDrawing.SelectionSets.Add("SS")
   0 B0 W) i# B$ S- d
5.     SS.Select acSelectionSetAll, , , FT, FD
     [% P9 c/ o$ j# b0 V
6.     If SS.Count > 1 Then
   : _! P5 _! v9 N9 }( Z4 O
7.         For I = SS.Count - 1 To 1 Step -1
   2 ^" G4 Z& t/ W) k
8.             Set C1 = SS.Item(I)
   
9.             For J = I - 1 To 0 Step -1
   
10.                 Set C2 = SS.Item(J)
    & [; s( K! e) f- }# i8 j& a
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
    
13.                     Exit For
    
14.                 End If
    
15.             Next
    8 ]8 W- l7 g) i6 V( i
16.         Next
    & ^) r' d& X9 W. U
17.     End If
    
18.     SS.Delete
    8 b6 x# B4 ~- g" A3 ]. w/ M  f4 V# J

复制代码

taqqug

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

cone521

我也在学习中，谢谢楼主

3duser

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

www1974

如果好了的话楼主将怎样删除线的命令一起研发下吧
& q7 x* t; k* F- d+ m" K2 b1 {3duser 发表于 2010-10-4 20:33 http://www.3dportal.cn/discuz/images/common/back.gif

安装ET工具，输入overkill即可