VBA怎样删除重复的圆？

taqqug

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

sealive_leafage

1 y3 X% Z4 l, [2 c# S) wcircle对象的center属性返回的是一维三元素数组，0代表圆心的x坐标，1代表圆心的y坐标，2代表圆心的z坐标，可以分别通过比较x、y、z坐标判断圆心是否相同，注意控制坐标值的对比位数；
circle对象的center属性示例代码如下：
Sub Example_Center()        
Dim circObj As AcadCircle   
  S& a- Y0 T2 t$ b" nDim currCenterPt(0 To 2) As Double   
Dim newCenterPt(0 To 2) As Double   
, M+ m" V, Y) `+ BDim radius As Double        
  b+ \/ {" w/ I% d, Z' Define the initial center point and radius for the circle   
" Z1 _& L3 F9 z0 K' TcurrCenterPt(0) = 20: currCenterPt(1) = 30: currCenterPt(2) = 0   
  e& @  e4 A0 jradius = 3        
* A+ x  I* I- P& m4 q! ?' Create the circle in model space   
Set circObj = ThisDrawing.ModelSpace.AddCircle(currCenterPt, radius)   
( z# c$ K2 v, J' p& ?( p1 J5 `* MZoomAll   
/ y1 f/ P1 l' |, p: D+ _, n+ gMsgBox "The center point of the circle is " & currCenterPt(0) & ", " & currCenterPt(1) & ", " & currCenterPt(2),vbInformation, "Center Example"   
9 x. Z0 w' r/ ~" \. w! i6 Y' Change the center point of the circle   
3 P4 K1 J% a2 j8 {5 A- UnewCenterPt(0) = 25: newCenterPt(1) = 25: newCenterPt(2) = 0   
+ `0 @% O! H, ?. k5 O$ E( hcircObj.center = newCenterPt   
circObj.Update        
- s- n" Q- q9 Q. A1 R' Query the results of the new center position   
1 Z+ `1 Z6 v: ^( p7 ?8 z, t' Notice the output from the center property is a variant   
. T, Z) ~0 N0 W) G7 z$ |9 S, e: UDim centerPoint As Variant   
: Y6 [) |& D. F3 L' v$ {& R$ X' R4 hcenterPoint = circObj.center   
) ~2 C$ s+ M) _5 hMsgBox "The center point of the circle is " & centerPoint(0) & ", " & centerPoint(1) & ", " & centerPoint(2),vbInformation, "Center Example"
1 P! c0 q- l2 E  Y6 V6 [! jEnd Sub

woaishuijia

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

1. 
   4 e/ L2 k( \' s' B: _+ i  ^/ E6 l
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"
   1 ]$ A1 [- d& ~& y6 y6 ]
4.     Set SS = ThisDrawing.SelectionSets.Add("SS")
   
5.     SS.Select acSelectionSetAll, , , FT, FD
     K) y6 P4 J  S# G
6.     If SS.Count > 1 Then
   
7.         For I = SS.Count - 1 To 1 Step -1
   
8.             Set C1 = SS.Item(I)
   
9.             For J = I - 1 To 0 Step -1
   
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
    & Y3 }0 u. E6 h( C1 O
12.                     C1.Delete
    # ?) }% [2 n) V4 P
13.                     Exit For
    6 j/ u" M( X1 S  G7 W) h" o
14.                 End If
    5 g, |3 V5 @8 R4 c6 o4 m& {6 a
15.             Next
    
16.         Next
    
17.     End If
    
18.     SS.Delete
    ! M6 ~1 b2 Q# M% G

复制代码

taqqug

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

cone521

我也在学习中，谢谢楼主

3duser

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

www1974

如果好了的话楼主将怎样删除线的命令一起研发下吧
, x  B$ l! o3 T0 U% Q0 B3duser 发表于 2010-10-4 20:33 http://www.3dportal.cn/discuz/images/common/back.gif

安装ET工具，输入overkill即可