欲删除模型空间中所有的红色的直线用VBA该如何写？

qianlinjun

请教各路高手，欲删除模型空间中所有的红色的直线用VBA该如何写？谢谢！

woaishuijia

1. 
   
2.     Dim E As AcadEntity
   , b+ U4 M- z2 k# M
3.     For Each E In ThisDrawing.ModelSpace
   
4.         If E.ObjectName = "AcDbLine" And (E.color = acRed Or E.color = acByLayer And ThisDrawing.Layers.Item(E.Layer).color = acRed) Then E.Delete
   
5.     Next
   

复制代码

qianlinjun

这个问题解决了，谢谢！
! K. z4 t1 y' i( A! a3 S$ v我初学autocad vba，有好多信息不知道在哪里找，比如line的objectname是“AcDbLine”
请问这些属性该怎么找？谢谢！
; _) z& u% V  ]( |4 R, K) B) f顺便另一个问题，如果我要删除所有半径为10的圆弧该如何写呢？
刚刚起步，问题比较傻瓜，还请不要见笑，谢谢啦！

woaishuijia

$ {9 i$ O% ?$ }" a* v6 ]2 Y0 R
: F0 x2 a8 d0 Y$ v/ T$ y2 Q! H' z利用"监视"查看现有图元的属性.
6 G1 V6 \6 j9 Q% ~) h; R& r8 S比如,在VBAIDE界面的代码窗口写一个空的过程

1. 
   : g* m" A+ s+ z# o& ?1 V: C1 B
2. Sub A
   
3. 
   5 o% f3 t7 i5 ^) A3 H- C1 l
4. End Sub
   

复制代码

在监视窗口中添加监视"Thisdrawing",然后按F8逐步运行这个过程(也可以用设置断点的方法),可以在监视窗口中看到当前文档及其子对象的绝大部分属性值.
2 j3 E+ J1 \) w+ M/ m, @8 ^当然,这其中并不包括每个图元的ObjectName属性值,但我们可以用相似的办法得到.
新建一个过程并在其中写入如下代码

1. 
   ; R/ u  [9 N7 F9 X
2.     Dim L As AcadLine, P1(2) As Double, P2(2) As Double
   
3.     P2(0) = 10
   
4.     Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)
   

复制代码

在监视窗口中添加监视"L.ObjectName".
当运行完第三行后,监视窗口就会显示出这条直线的"ObjectName"属性值为"AcDbLine".
# h/ s( ~  a/ O" W( N  ]
$ H, ^/ }( }2 S3 W4 R( ?"删除所有半径为10的圆弧"可以这样写

1. 
   2 H- ^7 F+ ], P6 J$ ?+ ~1 U; H
2.     Dim E As AcadEntity
   
3.     For Each E In ThisDrawing.ModelSpace
   ( t4 ~0 y" _2 j& U
4.         If E.ObjectName = "AcDbArc" Then
   ( Q( t7 v# L5 u0 u. g& \
5.             If E.Radius = 10 Then E.Delete
   
6.         End If
   / y2 `9 d6 ]2 E1 d+ L: H4 t
7.     Next
   

复制代码

qianlinjun

多谢版主的解释，关于监视，我还要研究一下：试了一下，还没有摸着门道。有没有相关教程呢？或者烦劳版主录一段小小的操作视频，以帮助我们这些初学者入门，不知是否可以？非常感谢！！！

qianlinjun

自己摸到了，不烦劳版主了，谢谢！！！

clearsee

版本就是热心哈..这样也顺便帮我看看..这段代码如何改写成VB/VBA代码,弧长标注..

1. (Defun C:DimArcLen()
   / q9 ]1 t1 p# T+ x2 A7 }
2.   (Vl-Load-Com)
   
3.   (SetQ EntPnt (EntSel "\n选择圆弧:")
   + v; P$ T6 Z1 B
4.         Ent    (Car EntPnt)
   
5.         Obj    (Vlax-EName->Vla-Object Ent)
   4 S4 I7 z1 f+ N. a8 H1 c- X! e: J
6.         Txt    (Rtos(Vla-Get-ArcLength  Obj) 2 2)
   
7.         Txt    (StrCat "\{\\Fgdt.shx|c0;^\}\\P" Txt)
   + \2 X- T% }0 m- m# ]' ]
8.   )
   
9.   (Command "_DimAngular" EntPnt "M" Txt )
   - Q# l% H% ^) n/ F6 z1 P# V
10. )
    

复制代码

woaishuijia

: Z, }. e  Q* `) `8 ~7# clearsee

1. 
   
2. Sub DimArcLen()
   9 D6 N  Z, i, ~2 R6 d* t
3.     Dim Space As AcadBlock, Obj As AcadEntity, Point As Variant, DimObj As AcadDim3PointAngular
   4 {, R8 {- F# i( v7 I
4.     On Error GoTo 10
   $ u* J: k) i$ x  ^( {, L0 d0 g
5.     With ThisDrawing
   3 K4 x& w7 {/ [9 z) n  G1 D( d
6.         If .ActiveSpace = acModelSpace Then
   
7.             Set Space = .ModelSpace
   / `1 i$ l, p" z( C5 p4 H. ~% Z
8.         Else
   ( o; C: \, }+ W& g0 S$ B" J
9.             Set Space = .PaperSpace
   % k* m6 H% O- E0 U
10.         End If
    % n6 M: x% m3 ^$ w* n! O
11.         .Utility.GetEntity Obj, Point, "选择圆弧:"
    
12.         If Obj.ObjectName = "AcDbArc" Then
    $ r2 h3 }3 j$ n9 O) y% n3 ?
13.             Set DimObj = Space.AddDim3PointAngular(Obj.Center, Obj.StartPoint, Obj.EndPoint, .Utility.GetPoint(, "指定标注弧线位置:" ))
    * q* g* r5 C8 r  y! }( B  ^6 ~
14.             DimObj.TextOverride = "{\Fgdt.shx|c0;^}\P" & Format(Obj.ArcLength, "0.##" )
    " P$ ]" y2 l  [+ l& G9 u! v
15.         End If
    
16.     End With
    8 j* w2 n, |# Z& K$ {
17. 10: End Sub
    

复制代码