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

qianlinjun

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

woaishuijia

1. 
   
2.     Dim E As AcadEntity
   
3.     For Each E In ThisDrawing.ModelSpace
   2 U+ ]4 X- Y! X# j  R' e5 S7 F
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
   & w  h" ]( P) ?6 O; P6 a

复制代码

qianlinjun

这个问题解决了，谢谢！
, ]% T$ z) a$ u* i# p: K' b- G9 P我初学autocad vba，有好多信息不知道在哪里找，比如line的objectname是“AcDbLine”
请问这些属性该怎么找？谢谢！
! p1 D# X6 \! l& g# y顺便另一个问题，如果我要删除所有半径为10的圆弧该如何写呢？
刚刚起步，问题比较傻瓜，还请不要见笑，谢谢啦！

woaishuijia

' V) b1 T: t! A, M
利用"监视"查看现有图元的属性.
比如,在VBAIDE界面的代码窗口写一个空的过程

1. 
   5 [# l  N/ ?) F4 J- l+ K& Y& r! n4 C
2. Sub A
   ( o/ H) d$ k: u, S9 ?/ a' r6 z; K
3. 
   2 T8 W( |& j2 V5 a$ z3 j5 Y
4. End Sub
   6 ?" ?: m% t1 u/ D; U& V9 z+ C0 k" [* N

复制代码

2 a9 _4 j. B9 l$ j) z在监视窗口中添加监视"Thisdrawing",然后按F8逐步运行这个过程(也可以用设置断点的方法),可以在监视窗口中看到当前文档及其子对象的绝大部分属性值.
当然,这其中并不包括每个图元的ObjectName属性值,但我们可以用相似的办法得到.
新建一个过程并在其中写入如下代码
) |2 g/ z9 t7 b% p5 `1 @* g

1. 
   
2.     Dim L As AcadLine, P1(2) As Double, P2(2) As Double
   4 i6 W8 o6 A/ h) n8 G
3.     P2(0) = 10
   
4.     Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)
   ) T1 a6 z1 }2 S# K/ l: f

复制代码

在监视窗口中添加监视"L.ObjectName".
  r' V5 o! W% B" j当运行完第三行后,监视窗口就会显示出这条直线的"ObjectName"属性值为"AcDbLine".
! l8 O2 N# [* L, o8 s# j3 j1 i
"删除所有半径为10的圆弧"可以这样写
* j* O- E7 ]1 I1 B7 e

1. 
   
2.     Dim E As AcadEntity
   
3.     For Each E In ThisDrawing.ModelSpace
   3 P4 ?5 b8 D" d- K( A, v
4.         If E.ObjectName = "AcDbArc" Then
   ) Y+ x- t$ S7 T$ V( M. q' j
5.             If E.Radius = 10 Then E.Delete
   
6.         End If
   
7.     Next
   

复制代码

qianlinjun

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

qianlinjun

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

clearsee

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

1. (Defun C:DimArcLen()
   ; |2 t- C- j/ B, p
2.   (Vl-Load-Com)
   
3.   (SetQ EntPnt (EntSel "\n选择圆弧:")
   
4.         Ent    (Car EntPnt)
   1 ?: C5 D& N- [- T$ N
5.         Obj    (Vlax-EName->Vla-Object Ent)
   
6.         Txt    (Rtos(Vla-Get-ArcLength  Obj) 2 2)
   
7.         Txt    (StrCat "\{\\Fgdt.shx|c0;^\}\\P" Txt)
   " b# D( R) ~1 R3 i2 w: o
8.   )
   
9.   (Command "_DimAngular" EntPnt "M" Txt )
   2 F& S8 x4 q# \* C5 T% E& }) o: j
10. )
    

复制代码

woaishuijia

! g$ O8 r( \+ H0 ~! J: }; p; G1 A
7# clearsee

1. 
   ; R# Q4 t" w% [" O8 E2 G! @
2. Sub DimArcLen()
   % K5 M/ A$ H- q, u0 s  J* G0 p8 ]
3.     Dim Space As AcadBlock, Obj As AcadEntity, Point As Variant, DimObj As AcadDim3PointAngular
   " x$ D& j3 ?& S
4.     On Error GoTo 10
   9 I1 O" {7 K8 |9 g
5.     With ThisDrawing
   ' b$ w9 A3 X, g8 ^* ]
6.         If .ActiveSpace = acModelSpace Then
   
7.             Set Space = .ModelSpace
   
8.         Else
   7 f+ ?3 p3 |" Y
9.             Set Space = .PaperSpace
   
10.         End If
    
11.         .Utility.GetEntity Obj, Point, "选择圆弧:"
    
12.         If Obj.ObjectName = "AcDbArc" Then
    
13.             Set DimObj = Space.AddDim3PointAngular(Obj.Center, Obj.StartPoint, Obj.EndPoint, .Utility.GetPoint(, "指定标注弧线位置:" ))
    
14.             DimObj.TextOverride = "{\Fgdt.shx|c0;^}\P" & Format(Obj.ArcLength, "0.##" )
    
15.         End If
    
16.     End With
    
17. 10: End Sub
      S7 v# q1 ^9 x5 Y' n' D! l

复制代码