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

qianlinjun

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

woaishuijia

1. 
   7 B+ N# P+ o& D# X
2.     Dim E As AcadEntity
   - N. G; q0 T8 Q; F0 G. ]) \
3.     For Each E In ThisDrawing.ModelSpace
   * m4 }3 N5 `4 A
4.         If E.ObjectName = "AcDbLine" And (E.color = acRed Or E.color = acByLayer And ThisDrawing.Layers.Item(E.Layer).color = acRed) Then E.Delete
   " T) {3 h# z* p. C2 B9 ]! \
5.     Next
   % E: T  L8 H0 v& y

复制代码

qianlinjun

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

woaishuijia

# v1 e5 X! Z9 a
+ x" Z. V( h" h, D8 m; M* {利用"监视"查看现有图元的属性.
比如,在VBAIDE界面的代码窗口写一个空的过程

1. 
   
2. Sub A
   
3. 
   - a5 y% V- M/ d) z: G, f
4. End Sub
   " \4 n6 w$ j" y7 ~' y3 R6 k/ [

复制代码

在监视窗口中添加监视"Thisdrawing",然后按F8逐步运行这个过程(也可以用设置断点的方法),可以在监视窗口中看到当前文档及其子对象的绝大部分属性值.
& |* _/ M' F  ]; S/ T当然,这其中并不包括每个图元的ObjectName属性值,但我们可以用相似的办法得到.
8 W- ?* V5 {. F5 n7 O; I新建一个过程并在其中写入如下代码
4 A3 w) F0 L3 A2 ]! E

1. 
   
2.     Dim L As AcadLine, P1(2) As Double, P2(2) As Double
   
3.     P2(0) = 10
   
4.     Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)
   

复制代码

在监视窗口中添加监视"L.ObjectName".
+ X' j$ H6 T. a当运行完第三行后,监视窗口就会显示出这条直线的"ObjectName"属性值为"AcDbLine".
4 I& {1 _) \/ N1 d
"删除所有半径为10的圆弧"可以这样写
" K& [' t/ X  j; b

1. 
   + {1 k1 o8 u: x" R* v* F" R
2.     Dim E As AcadEntity
   , U2 @6 _9 V" M6 e9 }- N& d
3.     For Each E In ThisDrawing.ModelSpace
     `  e/ x1 S) ~; F1 B
4.         If E.ObjectName = "AcDbArc" Then
   ! R$ h/ s$ N+ g# R, n
5.             If E.Radius = 10 Then E.Delete
   
6.         End If
   ; [) N0 x- v& T( f5 E6 }( Z7 g+ U
7.     Next
   " |# e' M( ~. U8 J! z* }/ b/ C7 ]# u- m, g

复制代码

qianlinjun

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

qianlinjun

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

clearsee

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

1. (Defun C:DimArcLen()
   7 D1 m7 p, G8 A9 P6 w- e( N
2.   (Vl-Load-Com)
   
3.   (SetQ EntPnt (EntSel "\n选择圆弧:")
   5 _6 e( y& K! A7 b7 Z9 h* v: [
4.         Ent    (Car EntPnt)
   
5.         Obj    (Vlax-EName->Vla-Object Ent)
   9 S2 ?5 e% n# B& q! s; I
6.         Txt    (Rtos(Vla-Get-ArcLength  Obj) 2 2)
   9 C4 r& A# T- f# A% g) {7 P( B
7.         Txt    (StrCat "\{\\Fgdt.shx|c0;^\}\\P" Txt)
   7 V6 o6 f0 ?- P& q1 ^; m
8.   )
   4 u2 i- h4 e1 B
9.   (Command "_DimAngular" EntPnt "M" Txt )
   $ q; H0 E$ S  j+ t
10. )
    

复制代码

woaishuijia

) A- A" h, N! ?$ v1 @7# clearsee

1. 
   
2. Sub DimArcLen()
   ; L) D$ P, @1 G3 n, a* L. Y
3.     Dim Space As AcadBlock, Obj As AcadEntity, Point As Variant, DimObj As AcadDim3PointAngular
   
4.     On Error GoTo 10
   2 ?# K& l7 h9 @4 m" d; ]# k$ u& y+ m6 f
5.     With ThisDrawing
   0 d4 g. n& a# }$ I
6.         If .ActiveSpace = acModelSpace Then
   - U' K0 u2 a; v/ {
7.             Set Space = .ModelSpace
   - H* ]8 a( @; d6 B, c
8.         Else
   
9.             Set Space = .PaperSpace
   ; ]! @; A) f' N1 ?) r, X( u
10.         End If
    9 c& R* Y0 n6 {8 O
11.         .Utility.GetEntity Obj, Point, "选择圆弧:"
    
12.         If Obj.ObjectName = "AcDbArc" Then
    5 [6 |8 l+ `3 F6 P4 n7 V
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
    : i4 X1 Q+ q! k1 T) h
16.     End With
    4 i8 {0 U  w. f' R6 Y' I- W: n
17. 10: End Sub
    

复制代码