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

qianlinjun

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

woaishuijia

1. 
   2 b* V% C# g2 d
2.     Dim E As AcadEntity
   ' K" M# j- q# |" p: W6 C' Y, q
3.     For Each E In ThisDrawing.ModelSpace
   ) Z& j5 w( r* N3 H& c
4.         If E.ObjectName = "AcDbLine" And (E.color = acRed Or E.color = acByLayer And ThisDrawing.Layers.Item(E.Layer).color = acRed) Then E.Delete
   7 ~$ P8 C: r, M' Q( s
5.     Next
   . _' B$ K' ~. |! R, b3 T

复制代码

qianlinjun

这个问题解决了，谢谢！
- F' w! ?" k" J8 K' F' u我初学autocad vba，有好多信息不知道在哪里找，比如line的objectname是“AcDbLine”
请问这些属性该怎么找？谢谢！
顺便另一个问题，如果我要删除所有半径为10的圆弧该如何写呢？
刚刚起步，问题比较傻瓜，还请不要见笑，谢谢啦！

woaishuijia

( E- T, X+ S+ F# g5 P
利用"监视"查看现有图元的属性.
5 k1 F# c) u) J* p) v) @比如,在VBAIDE界面的代码窗口写一个空的过程

1. 
   3 J- q+ f9 Z4 F/ [
2. Sub A
   
3. 
   
4. End Sub
   / j: k) Q- |: b8 r& T+ F% ?

复制代码

在监视窗口中添加监视"Thisdrawing",然后按F8逐步运行这个过程(也可以用设置断点的方法),可以在监视窗口中看到当前文档及其子对象的绝大部分属性值.
当然,这其中并不包括每个图元的ObjectName属性值,但我们可以用相似的办法得到.
$ m6 s1 E+ v  f1 K9 Y1 K" Q  p新建一个过程并在其中写入如下代码

1. 
   7 W  z: J5 S& z) ^
2.     Dim L As AcadLine, P1(2) As Double, P2(2) As Double
   
3.     P2(0) = 10
   , [- X; }% x$ F& `. f7 n$ a
4.     Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)
   0 J$ v3 F6 c" u2 c* G0 ]

复制代码

在监视窗口中添加监视"L.ObjectName".
4 _% ^# l* v! E* p' E/ h+ ~当运行完第三行后,监视窗口就会显示出这条直线的"ObjectName"属性值为"AcDbLine".
# ~, `2 w2 J1 h9 z9 d2 w: D
, X; b+ {5 `; h0 @% f"删除所有半径为10的圆弧"可以这样写

1. 
   
2.     Dim E As AcadEntity
   3 \: m/ q1 a2 e$ M
3.     For Each E In ThisDrawing.ModelSpace
   * [$ S: D- e% W
4.         If E.ObjectName = "AcDbArc" Then
   & y" U1 X- z' X% g: ]* L
5.             If E.Radius = 10 Then E.Delete
   
6.         End If
   2 Z1 y) ?7 D% K& J# {1 I% P
7.     Next
   

复制代码

qianlinjun

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

qianlinjun

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

clearsee

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

1. (Defun C:DimArcLen()
   
2.   (Vl-Load-Com)
   
3.   (SetQ EntPnt (EntSel "\n选择圆弧:")
   9 d- C8 w* D; ?
4.         Ent    (Car EntPnt)
   
5.         Obj    (Vlax-EName->Vla-Object Ent)
   
6.         Txt    (Rtos(Vla-Get-ArcLength  Obj) 2 2)
   , c2 U3 o$ z! q, t! {: p, {) o
7.         Txt    (StrCat "\{\\Fgdt.shx|c0;^\}\\P" Txt)
   
8.   )
   , ?" a9 J& k1 O! n$ X6 N
9.   (Command "_DimAngular" EntPnt "M" Txt )
   8 {3 L6 d0 \; t* O- F5 r
10. )
    

复制代码

woaishuijia

7# clearsee

1. 
   
2. Sub DimArcLen()
   
3.     Dim Space As AcadBlock, Obj As AcadEntity, Point As Variant, DimObj As AcadDim3PointAngular
   
4.     On Error GoTo 10
   % Y  `0 X+ j( e) |
5.     With ThisDrawing
   
6.         If .ActiveSpace = acModelSpace Then
   8 T; m, G' F7 {1 a
7.             Set Space = .ModelSpace
   
8.         Else
   
9.             Set Space = .PaperSpace
   & H8 X+ {6 o1 r9 f3 j
10.         End If
    
11.         .Utility.GetEntity Obj, Point, "选择圆弧:"
      n7 U4 n* I2 U5 z, o
12.         If Obj.ObjectName = "AcDbArc" Then
    4 d! J7 g$ [4 T  @# w
13.             Set DimObj = Space.AddDim3PointAngular(Obj.Center, Obj.StartPoint, Obj.EndPoint, .Utility.GetPoint(, "指定标注弧线位置:" ))
    
14.             DimObj.TextOverride = "{\Fgdt.shx|c0;^}\P" & Format(Obj.ArcLength, "0.##" )
    1 l1 r% \2 K+ N
15.         End If
    
16.     End With
    
17. 10: End Sub
      R5 E/ c: l0 f

复制代码