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

qianlinjun

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

woaishuijia

1. 
   
2.     Dim E As AcadEntity
   
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
   5 U( q7 N( `# [/ U

复制代码

qianlinjun

这个问题解决了，谢谢！
; m" |5 U0 M2 O( o) x9 J我初学autocad vba，有好多信息不知道在哪里找，比如line的objectname是“AcDbLine”
请问这些属性该怎么找？谢谢！
* y1 c) |1 N8 y/ n9 [顺便另一个问题，如果我要删除所有半径为10的圆弧该如何写呢？
+ k7 h2 p2 s. _/ @刚刚起步，问题比较傻瓜，还请不要见笑，谢谢啦！

woaishuijia

' u# B/ m* R0 a利用"监视"查看现有图元的属性.
比如,在VBAIDE界面的代码窗口写一个空的过程

1. 
   & m- S8 ?- c- q
2. Sub A
   $ k5 |+ @! y' k. p6 r5 V
3. 
   ! \+ f* I$ |& M  y3 Y
4. End Sub
     x; h% R8 C* ^; F: T8 Y5 @

复制代码

在监视窗口中添加监视"Thisdrawing",然后按F8逐步运行这个过程(也可以用设置断点的方法),可以在监视窗口中看到当前文档及其子对象的绝大部分属性值.
% P4 _1 S( i$ C/ q7 @当然,这其中并不包括每个图元的ObjectName属性值,但我们可以用相似的办法得到.
新建一个过程并在其中写入如下代码
1 e" c' |9 ]( w7 l( ]* t, `

1. 
   
2.     Dim L As AcadLine, P1(2) As Double, P2(2) As Double
     ]# H6 O- c5 o# A4 `  K3 @3 c
3.     P2(0) = 10
   
4.     Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)
   , m) U" F5 i7 w4 \  h3 ?7 Y  {

复制代码

在监视窗口中添加监视"L.ObjectName".
当运行完第三行后,监视窗口就会显示出这条直线的"ObjectName"属性值为"AcDbLine".
1 }: ?- |2 P) w! _; o, I( Z
2 g6 M1 ^5 o4 _' v/ i& F/ t) v"删除所有半径为10的圆弧"可以这样写

1. 
   ' x, Z/ w( @. B+ o
2.     Dim E As AcadEntity
   & e4 w7 @) E9 T& C: b$ ]
3.     For Each E In ThisDrawing.ModelSpace
   ) _0 n8 q4 U( E/ F! ~& N$ Z
4.         If E.ObjectName = "AcDbArc" Then
   
5.             If E.Radius = 10 Then E.Delete
   
6.         End If
   
7.     Next
   

复制代码

qianlinjun

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

qianlinjun

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

clearsee

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

1. (Defun C:DimArcLen()
   7 p& [0 B  w1 t7 d6 e
2.   (Vl-Load-Com)
   ) S, Z3 y5 ?( C7 [. K1 c
3.   (SetQ EntPnt (EntSel "\n选择圆弧:")
   " s/ I& s! A3 }, o; w8 @
4.         Ent    (Car EntPnt)
   % p5 C$ {& j, E3 N2 K5 F' }
5.         Obj    (Vlax-EName->Vla-Object Ent)
   ! M# H: u) I8 s8 V; [/ s& K
6.         Txt    (Rtos(Vla-Get-ArcLength  Obj) 2 2)
   
7.         Txt    (StrCat "\{\\Fgdt.shx|c0;^\}\\P" Txt)
   2 q6 G3 G( }" G) r& p+ x( Q7 F
8.   )
   % f, O" ^/ u" j, U  {
9.   (Command "_DimAngular" EntPnt "M" Txt )
   
10. )
    

复制代码

woaishuijia

7# clearsee

1. 
   6 d  C! p! q# x( P
2. Sub DimArcLen()
   
3.     Dim Space As AcadBlock, Obj As AcadEntity, Point As Variant, DimObj As AcadDim3PointAngular
   - Y1 s! {9 u1 g) g2 n
4.     On Error GoTo 10
   
5.     With ThisDrawing
   0 G+ C& Y* V$ u. s+ j# [9 E* E8 B
6.         If .ActiveSpace = acModelSpace Then
   
7.             Set Space = .ModelSpace
   & l! r# ~) y1 X3 P" X7 g7 ?" }
8.         Else
   
9.             Set Space = .PaperSpace
   / ~& C9 A% X8 H5 M, U' B
10.         End If
    
11.         .Utility.GetEntity Obj, Point, "选择圆弧:"
    * d) H, i( P) V! j2 o9 L
12.         If Obj.ObjectName = "AcDbArc" Then
    
13.             Set DimObj = Space.AddDim3PointAngular(Obj.Center, Obj.StartPoint, Obj.EndPoint, .Utility.GetPoint(, "指定标注弧线位置:" ))
    % P) J" y; q( }) E
14.             DimObj.TextOverride = "{\Fgdt.shx|c0;^}\P" & Format(Obj.ArcLength, "0.##" )
    
15.         End If
    
16.     End With
    $ {8 Q$ o9 Z: r4 x5 w+ Z
17. 10: End Sub
    

复制代码