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

qianlinjun

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

woaishuijia

1. 
   
2.     Dim E As AcadEntity
   % u- S* x& F( d) X3 l7 A; M
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
     v: R; h" m+ B3 i0 |
5.     Next
   

复制代码

qianlinjun

这个问题解决了，谢谢！
. e; p" N% L; x7 t2 `6 U% u: A我初学autocad vba，有好多信息不知道在哪里找，比如line的objectname是“AcDbLine”
请问这些属性该怎么找？谢谢！
/ ?% _' v$ _7 ~& T) O顺便另一个问题，如果我要删除所有半径为10的圆弧该如何写呢？
刚刚起步，问题比较傻瓜，还请不要见笑，谢谢啦！

woaishuijia

0 T! a5 v, C1 Y' r0 z4 G7 {% C利用"监视"查看现有图元的属性.
比如,在VBAIDE界面的代码窗口写一个空的过程

1. 
   % H# W$ V2 U1 L/ }: B
2. Sub A
   - U3 V4 ]- x" S+ c. Y0 W
3. 
   $ ^/ U' A8 K" s) ]
4. End Sub
   

复制代码

在监视窗口中添加监视"Thisdrawing",然后按F8逐步运行这个过程(也可以用设置断点的方法),可以在监视窗口中看到当前文档及其子对象的绝大部分属性值.
, Q& ^6 B. j5 O: w+ M( F  X! \5 |当然,这其中并不包括每个图元的ObjectName属性值,但我们可以用相似的办法得到.
( y1 Y) W% N- r/ p& @: n新建一个过程并在其中写入如下代码

1. 
   ) g7 u: U: _* {3 `3 L
2.     Dim L As AcadLine, P1(2) As Double, P2(2) As Double
   
3.     P2(0) = 10
   + Z( T4 W+ ~( \! s5 ~
4.     Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)
   

复制代码

在监视窗口中添加监视"L.ObjectName".
当运行完第三行后,监视窗口就会显示出这条直线的"ObjectName"属性值为"AcDbLine".
4 \9 d( [0 y8 @2 L; S9 s
"删除所有半径为10的圆弧"可以这样写
6 ~  a% Z  [3 \+ G" a  L

1. 
   9 h+ q8 b9 v* t4 v9 @( C
2.     Dim E As AcadEntity
   1 n2 V8 Y0 b& a. ?, S1 h
3.     For Each E In ThisDrawing.ModelSpace
   
4.         If E.ObjectName = "AcDbArc" Then
   * y' M5 J: Q! Q% B! u7 R& l
5.             If E.Radius = 10 Then E.Delete
   5 W+ p+ k/ _8 _. y8 p# b1 g  F
6.         End If
   
7.     Next
   # H* g( v; S0 D% _+ V% m6 k1 t. [% U

复制代码

qianlinjun

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

qianlinjun

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

clearsee

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

1. (Defun C:DimArcLen()
   - Z: |8 Z" b. E
2.   (Vl-Load-Com)
   
3.   (SetQ EntPnt (EntSel "\n选择圆弧:")
   ' ~- ~  J# \1 Z, x1 o6 U
4.         Ent    (Car EntPnt)
   
5.         Obj    (Vlax-EName->Vla-Object Ent)
   
6.         Txt    (Rtos(Vla-Get-ArcLength  Obj) 2 2)
   
7.         Txt    (StrCat "\{\\Fgdt.shx|c0;^\}\\P" Txt)
   3 r# t+ H/ r7 j2 D+ K9 U7 [- q
8.   )
   ' x0 e9 M  r- ^/ {2 t  Q
9.   (Command "_DimAngular" EntPnt "M" Txt )
   
10. )
    , k0 }2 @; Q6 |9 N

复制代码

woaishuijia

% x5 y# `( }2 C. X8 ^! f$ t" ^
7# clearsee

1. 
   
2. Sub DimArcLen()
   
3.     Dim Space As AcadBlock, Obj As AcadEntity, Point As Variant, DimObj As AcadDim3PointAngular
   0 J( K+ `- _( A+ a
4.     On Error GoTo 10
   
5.     With ThisDrawing
   % g0 z2 Y# I; S# i) j: U$ O6 [/ R% ]
6.         If .ActiveSpace = acModelSpace Then
   
7.             Set Space = .ModelSpace
   : D$ f0 m/ X# A  n, _
8.         Else
   
9.             Set Space = .PaperSpace
   0 d/ m1 N- M1 s3 i
10.         End If
    
11.         .Utility.GetEntity Obj, Point, "选择圆弧:"
    + S& v, G! }; q! A
12.         If Obj.ObjectName = "AcDbArc" Then
    ; P  Z- \% g# h
13.             Set DimObj = Space.AddDim3PointAngular(Obj.Center, Obj.StartPoint, Obj.EndPoint, .Utility.GetPoint(, "指定标注弧线位置:" ))
    
14.             DimObj.TextOverride = "{\Fgdt.shx|c0;^}\P" & Format(Obj.ArcLength, "0.##" )
    7 o4 G1 f4 W: s8 @9 ?) ]
15.         End If
    & T4 h% z0 R* q  H" J' p6 {$ V
16.     End With
    
17. 10: End Sub
    2 O6 u! n5 r$ \

复制代码