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

qianlinjun

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

woaishuijia

1. 
   / g. z! h: i8 y
2.     Dim E As AcadEntity
   2 g  T4 R9 G. A' P# F
3.     For Each E In ThisDrawing.ModelSpace
   ( ~5 c& @; R& B/ |6 m* H9 ~
4.         If E.ObjectName = "AcDbLine" And (E.color = acRed Or E.color = acByLayer And ThisDrawing.Layers.Item(E.Layer).color = acRed) Then E.Delete
   3 N1 r# F% o0 V: h3 T
5.     Next
   ) q7 u- S1 u# U- K: k

复制代码

qianlinjun

这个问题解决了，谢谢！
我初学autocad vba，有好多信息不知道在哪里找，比如line的objectname是“AcDbLine”
请问这些属性该怎么找？谢谢！
# h" P  |; {6 [/ F9 W顺便另一个问题，如果我要删除所有半径为10的圆弧该如何写呢？
' x  \1 V" r* T# u7 A6 I! O4 a刚刚起步，问题比较傻瓜，还请不要见笑，谢谢啦！

woaishuijia

利用"监视"查看现有图元的属性.
; e+ m4 j* F0 a; ]4 P比如,在VBAIDE界面的代码窗口写一个空的过程

1. 
   
2. Sub A
   
3. 
   8 |8 v+ |& ]! F9 V6 D  Y$ y
4. End Sub
   7 z/ ^. R2 ]; v" O% B

复制代码

在监视窗口中添加监视"Thisdrawing",然后按F8逐步运行这个过程(也可以用设置断点的方法),可以在监视窗口中看到当前文档及其子对象的绝大部分属性值.
当然,这其中并不包括每个图元的ObjectName属性值,但我们可以用相似的办法得到.
! n* \2 b. g% A* X$ @; f' A2 L新建一个过程并在其中写入如下代码
% ]7 t" @: B* M% A5 {* T) U

1. 
   
2.     Dim L As AcadLine, P1(2) As Double, P2(2) As Double
   & W7 ]# b3 L7 n' r6 s' t7 x
3.     P2(0) = 10
   ) t& A- O( p/ s' J7 ^% `. V2 Q" R
4.     Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)
   6 ?% E6 Y; L1 Q, Y% d" n/ ?

复制代码

在监视窗口中添加监视"L.ObjectName".
当运行完第三行后,监视窗口就会显示出这条直线的"ObjectName"属性值为"AcDbLine".
5 l) G7 U6 Y8 V
! o4 s8 b" r( L: f"删除所有半径为10的圆弧"可以这样写
1 V4 n3 k4 j3 g0 l/ L

1. 
   
2.     Dim E As AcadEntity
   
3.     For Each E In ThisDrawing.ModelSpace
   . g7 h' c0 ^& e0 f
4.         If E.ObjectName = "AcDbArc" Then
   ' N8 r  }8 ^( v) R! \4 {, i
5.             If E.Radius = 10 Then E.Delete
   , m4 L1 B: `1 f3 x
6.         End If
   8 O" Q$ X( L2 s) w. _7 X
7.     Next
   6 L- ?; S- y. w, [2 Y! ^

复制代码

qianlinjun

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

qianlinjun

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

clearsee

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

1. (Defun C:DimArcLen()
   
2.   (Vl-Load-Com)
   
3.   (SetQ EntPnt (EntSel "\n选择圆弧:")
   0 m) z( M7 j8 Y& H7 \# M5 V" M
4.         Ent    (Car EntPnt)
   
5.         Obj    (Vlax-EName->Vla-Object Ent)
   1 Q& Y7 ]0 v4 [% l! ~; W
6.         Txt    (Rtos(Vla-Get-ArcLength  Obj) 2 2)
   
7.         Txt    (StrCat "\{\\Fgdt.shx|c0;^\}\\P" Txt)
   
8.   )
   
9.   (Command "_DimAngular" EntPnt "M" Txt )
   $ K4 u8 _0 c# D( J, R5 N
10. )
    1 o# d" P* Q5 L( W# ?+ n2 {; g

复制代码

woaishuijia

  w+ `0 R( Q8 O/ Y/ Q9 m7# clearsee

1. 
   
2. Sub DimArcLen()
   
3.     Dim Space As AcadBlock, Obj As AcadEntity, Point As Variant, DimObj As AcadDim3PointAngular
   & D5 c( w! f: _5 P
4.     On Error GoTo 10
   1 F" k" N' f0 L: e1 N! q
5.     With ThisDrawing
   " v6 l# N. {% k2 |) _5 v
6.         If .ActiveSpace = acModelSpace Then
   
7.             Set Space = .ModelSpace
   
8.         Else
   + ?/ j6 b& A1 s
9.             Set Space = .PaperSpace
   ( O" a2 p( Z# u
10.         End If
    3 c( }  k+ X8 g, A' T# i3 |% g
11.         .Utility.GetEntity Obj, Point, "选择圆弧:"
    5 J) d; L8 A1 k3 N: @
12.         If Obj.ObjectName = "AcDbArc" Then
    
13.             Set DimObj = Space.AddDim3PointAngular(Obj.Center, Obj.StartPoint, Obj.EndPoint, .Utility.GetPoint(, "指定标注弧线位置:" ))
    $ i; c  _0 B/ V0 p( {. K
14.             DimObj.TextOverride = "{\Fgdt.shx|c0;^}\P" & Format(Obj.ArcLength, "0.##" )
    
15.         End If
    
16.     End With
    
17. 10: End Sub
    1 ?. D  X) A; |

复制代码