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

qianlinjun

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

woaishuijia

1. 
   - L4 L3 h' n( A0 r( H$ l( G. Y* D
2.     Dim E As AcadEntity
   * V' d1 U) q3 l: K# f4 ]1 B
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
   ( c# {& X/ ?, U! v; x
5.     Next
   

复制代码

qianlinjun

这个问题解决了，谢谢！
8 [) U2 Q3 O, g& Q5 ~2 L  X我初学autocad vba，有好多信息不知道在哪里找，比如line的objectname是“AcDbLine”
请问这些属性该怎么找？谢谢！
; s. V" j# G$ ~' \顺便另一个问题，如果我要删除所有半径为10的圆弧该如何写呢？
刚刚起步，问题比较傻瓜，还请不要见笑，谢谢啦！

woaishuijia

8 L5 P0 x4 x  c" Z  w利用"监视"查看现有图元的属性.
比如,在VBAIDE界面的代码窗口写一个空的过程

1. 
   
2. Sub A
   : M" h9 {- T- ]2 d- M
3. 
   : z% O! F) t4 _8 H( H, E. P5 n; V5 i
4. End Sub
   ) O) I  u5 g9 D; k' I( c

复制代码

在监视窗口中添加监视"Thisdrawing",然后按F8逐步运行这个过程(也可以用设置断点的方法),可以在监视窗口中看到当前文档及其子对象的绝大部分属性值.
当然,这其中并不包括每个图元的ObjectName属性值,但我们可以用相似的办法得到.
新建一个过程并在其中写入如下代码
6 \" }4 }* p* a. i& P( H

1. 
   
2.     Dim L As AcadLine, P1(2) As Double, P2(2) As Double
   : u) ~, Q, u  s
3.     P2(0) = 10
   9 o' I: H( S+ T0 Z! V8 F$ y
4.     Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)
   ) y1 |8 Z- z2 q2 c

复制代码

在监视窗口中添加监视"L.ObjectName".
: L/ @5 z1 F/ `6 u5 ^5 C7 u6 h0 p3 a当运行完第三行后,监视窗口就会显示出这条直线的"ObjectName"属性值为"AcDbLine".

( [5 V. _& _8 c, b3 C6 Z"删除所有半径为10的圆弧"可以这样写
( R6 ?+ i6 [% [

1. 
   9 A1 ~/ ?) M, h0 E2 O2 ]) V+ W% @7 j
2.     Dim E As AcadEntity
   ; U! _" M2 F! o3 ~6 L$ f
3.     For Each E In ThisDrawing.ModelSpace
   & q; p, N  M7 X5 k3 [% Q0 Y2 e' `
4.         If E.ObjectName = "AcDbArc" Then
   
5.             If E.Radius = 10 Then E.Delete
   
6.         End If
   
7.     Next
   

复制代码

qianlinjun

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

qianlinjun

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

clearsee

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

1. (Defun C:DimArcLen()
   
2.   (Vl-Load-Com)
   
3.   (SetQ EntPnt (EntSel "\n选择圆弧:")
   1 ?: |: g; e* e7 }" b
4.         Ent    (Car EntPnt)
   4 q2 j* E2 L9 x  j* f8 O+ \/ M, L
5.         Obj    (Vlax-EName->Vla-Object Ent)
   
6.         Txt    (Rtos(Vla-Get-ArcLength  Obj) 2 2)
   ; T7 n/ l2 I1 H% H4 X6 ?
7.         Txt    (StrCat "\{\\Fgdt.shx|c0;^\}\\P" Txt)
   
8.   )
   $ q) M5 l, I' E8 {; l0 Z4 C
9.   (Command "_DimAngular" EntPnt "M" Txt )
   ( J0 _' E0 W* l- [
10. )
    - a; J, n7 A! C% `

复制代码

woaishuijia

. Z7 z% Q. \5 F; N
7# clearsee

1. 
   
2. Sub DimArcLen()
   
3.     Dim Space As AcadBlock, Obj As AcadEntity, Point As Variant, DimObj As AcadDim3PointAngular
   " c( v; R3 P" Z3 `
4.     On Error GoTo 10
   - n" J1 h: h1 C$ X
5.     With ThisDrawing
   / g$ q" T5 e. ^. [
6.         If .ActiveSpace = acModelSpace Then
   6 \6 H5 {' e+ f  |+ Z% i
7.             Set Space = .ModelSpace
   $ T4 @$ }, k) \) `1 R/ G" c3 d
8.         Else
   
9.             Set Space = .PaperSpace
   7 u# a4 D7 R5 ~2 G/ G/ J
10.         End If
    
11.         .Utility.GetEntity Obj, Point, "选择圆弧:"
    
12.         If Obj.ObjectName = "AcDbArc" Then
    * w9 V- W7 ?) J* d% q. |( X6 b/ P
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
    1 F2 S5 G  W* ~7 m& {( p
17. 10: End Sub
    

复制代码