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

qianlinjun

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

woaishuijia

1. 
   * Q. X1 S* x9 ^( P, B
2.     Dim E As AcadEntity
   
3.     For Each E In ThisDrawing.ModelSpace
   6 w$ L  U4 a! J( p+ w( g! z
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

这个问题解决了，谢谢！
0 a. U- a, g7 F我初学autocad vba，有好多信息不知道在哪里找，比如line的objectname是“AcDbLine”
) V5 i- Q7 L# |+ ]请问这些属性该怎么找？谢谢！
顺便另一个问题，如果我要删除所有半径为10的圆弧该如何写呢？
7 A; M& x% |' X$ u+ C刚刚起步，问题比较傻瓜，还请不要见笑，谢谢啦！

woaishuijia

利用"监视"查看现有图元的属性.
" w- {' s; ]$ E比如,在VBAIDE界面的代码窗口写一个空的过程

1. 
   
2. Sub A
   ( ~* C8 a1 z  _1 x. M, ^3 L# Z3 a9 ^
3. 
   5 t7 L+ L& e& _+ `* s
4. End Sub
   

复制代码

在监视窗口中添加监视"Thisdrawing",然后按F8逐步运行这个过程(也可以用设置断点的方法),可以在监视窗口中看到当前文档及其子对象的绝大部分属性值.
5 w+ w. {0 q6 t/ X当然,这其中并不包括每个图元的ObjectName属性值,但我们可以用相似的办法得到.
新建一个过程并在其中写入如下代码
1 J; T7 |* b$ i% t: D; I

1. 
   & s" O: Z: R, G: |; A* L5 P) ]+ C2 `
2.     Dim L As AcadLine, P1(2) As Double, P2(2) As Double
   8 ?: ~) f7 W& a' O- Y
3.     P2(0) = 10
   3 S: ]0 [* o9 x& O9 [. j5 I) t
4.     Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)
   , Y' I- |0 M4 y* G' Y- A

复制代码

在监视窗口中添加监视"L.ObjectName".
当运行完第三行后,监视窗口就会显示出这条直线的"ObjectName"属性值为"AcDbLine".

# l, _- v! Q- y"删除所有半径为10的圆弧"可以这样写
4 P# |: Q' o( c5 X) F8 l

1. 
   0 f6 p0 O4 g; l% O+ A; S
2.     Dim E As AcadEntity
   5 b! {- P0 e6 C; ~( F; Q8 i
3.     For Each E In ThisDrawing.ModelSpace
   
4.         If E.ObjectName = "AcDbArc" Then
   
5.             If E.Radius = 10 Then E.Delete
   
6.         End If
   9 k( l1 P% s5 C
7.     Next
   

复制代码

qianlinjun

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

qianlinjun

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

clearsee

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

1. (Defun C:DimArcLen()
   
2.   (Vl-Load-Com)
   5 b- q- c9 N5 @5 `0 m5 x
3.   (SetQ EntPnt (EntSel "\n选择圆弧:")
   ( ~/ u9 o& {7 C
4.         Ent    (Car EntPnt)
   - X/ }# Y4 j& {9 R& n9 n
5.         Obj    (Vlax-EName->Vla-Object Ent)
   
6.         Txt    (Rtos(Vla-Get-ArcLength  Obj) 2 2)
   & s# v3 O" h- P
7.         Txt    (StrCat "\{\\Fgdt.shx|c0;^\}\\P" Txt)
   
8.   )
   * M0 z& o6 {* j8 V- b
9.   (Command "_DimAngular" EntPnt "M" Txt )
   
10. )
    5 L/ e- `( }3 j& v5 X

复制代码

woaishuijia

- [$ w) v' a& H7# clearsee

1. 
   
2. Sub DimArcLen()
   # s! F- E4 H, c) B4 A
3.     Dim Space As AcadBlock, Obj As AcadEntity, Point As Variant, DimObj As AcadDim3PointAngular
   ' [& ~- x( ~/ |$ P/ I
4.     On Error GoTo 10
   
5.     With ThisDrawing
   - N  s8 r: @& q& e. p: M) P$ F/ o" ~
6.         If .ActiveSpace = acModelSpace Then
   9 [: t0 G7 }( y+ B+ u  ?
7.             Set Space = .ModelSpace
   . @- ]4 X% ~7 l  M
8.         Else
   6 I: c/ N/ p! Y7 m- y5 R6 H
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.##" )
    3 L0 f, e& K% [( l% W
15.         End If
    2 ]5 ]8 O8 }+ Z
16.     End With
    ' P: g6 f3 R) u
17. 10: End Sub
    ( Y. [9 m6 Z# ?9 P, D- X

复制代码