VBA怎样删除重复的圆？

taqqug

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

sealive_leafage

0 Q& a  Y! S, E& E6 z3 c' Y; |) P
+ q4 F8 x1 c4 E1 G+ Qcircle对象的center属性返回的是一维三元素数组，0代表圆心的x坐标，1代表圆心的y坐标，2代表圆心的z坐标，可以分别通过比较x、y、z坐标判断圆心是否相同，注意控制坐标值的对比位数；
circle对象的center属性示例代码如下：
% m; z* l7 ]( i) K! [Sub Example_Center()        
Dim circObj As AcadCircle   
Dim currCenterPt(0 To 2) As Double   
- S! `$ L3 I- s" C5 |- m, S, Y& v2 ^$ QDim newCenterPt(0 To 2) As Double   
  n3 r! n% h, u% y# N4 G- ~1 fDim radius As Double        
' Define the initial center point and radius for the circle   
7 X  f& H0 z- c2 |currCenterPt(0) = 20: currCenterPt(1) = 30: currCenterPt(2) = 0   
+ ^& `: P! M4 w9 ?1 L6 V4 Eradius = 3        
( ^' E# s( T7 a0 `' Create the circle in model space   
Set circObj = ThisDrawing.ModelSpace.AddCircle(currCenterPt, radius)   
6 m7 T8 R3 V( ], s  QZoomAll   
8 x8 a$ M% S& D, J/ d+ _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   
8 r( M3 E7 L7 y$ @. ?- k$ ?6 }circObj.center = newCenterPt   
circObj.Update        
) s5 f( n  i$ a. z# e0 j# P. ~' Query the results of the new center position   
4 x; l7 L& r: ]# Q; x" Q' Notice the output from the center property is a variant   
; r* v# t3 L! j1 d$ TDim centerPoint As Variant   
centerPoint = circObj.center   
MsgBox "The center point of the circle is " & centerPoint(0) & ", " & centerPoint(1) & ", " & centerPoint(2),vbInformation, "Center Example"
* E$ ]; G7 r& MEnd 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( p3 G6 t+ y) M
3.     FT(0) = 0: FD(0) = "Circle"
   7 B; A  m# m8 Q/ g
4.     Set SS = ThisDrawing.SelectionSets.Add("SS")
     A* j# |4 M0 ^; i6 W
5.     SS.Select acSelectionSetAll, , , FT, FD
   
6.     If SS.Count > 1 Then
     l* n3 \. x# R. f4 x
7.         For I = SS.Count - 1 To 1 Step -1
   # V( T* Z: b) A+ k) z7 S, y* f, K
8.             Set C1 = SS.Item(I)
   / |/ b: b+ c! K6 B
9.             For J = I - 1 To 0 Step -1
   2 S( {$ ^2 |/ l- w7 Q
10.                 Set C2 = SS.Item(J)
    * U" x+ b9 x6 _5 w% M5 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
    
13.                     Exit For
      t6 T; _1 _* I) h- O0 d
14.                 End If
    
15.             Next
    4 p, C9 n  @0 e( A) p: c3 B8 l2 ^
16.         Next
    
17.     End If
    
18.     SS.Delete
    7 ^8 b$ h' @5 K' b2 \% _

复制代码

taqqug

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

cone521

我也在学习中，谢谢楼主

3duser

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

www1974

如果好了的话楼主将怎样删除线的命令一起研发下吧
" z- n; k% S. W, s3duser 发表于 2010-10-4 20:33 http://www.3dportal.cn/discuz/images/common/back.gif

$ ?( m; ]! |! u& s安装ET工具，输入overkill即可