急求:将圆批量转为块的程序

mccad

subtlation发表于2004-3-19 8:38:00请教一下明总： For i = 0 To ss.Count - 1 语句 next 是不是每次运行循环回到for语句时，ss,count就会重新计算一次？ 还有就是CS.Erase语句把圆...

1.For ...Next是循环语句，循环过程中ss.Count不重新计算，而只计算第一次，然后按每循环一次i值递增1。 2.CS.Erase删除对象后，选择集中的对象数量会变小，但对于循环的次数不会改变。 3.假定是实体ss(2)被删除，那么以后引用ss(2)时，会出错，所以程序设置了出错判断来跳过。

wyj_007

要取得同心圆块，应当把所有圆心点归到同一个点集中ss ，取出其中一个点P1，再把这个点与点集中ss的点比较，若有n个相等值(n>0)，则把n个相等值点P2对应的圆O2归入一起B1块中，同时把P2移出点集ss ,再此循环以上操作，直到点集ss 为 nil为止。

mccad

取同心圆其实很简单，也用带过滤器的选择集，过滤出同心的圆，有没有看到我在VBA中的写法，就是用这种方法。

龙龙仔

usercoolbo发表于2004-3-17 10:46:00能不能用LISP编写啊,VBA我有点看不懂,谢了

;;將圓批量轉為塊的程式
;;By 龍龍仔(LUCAS)
(defun C:CBB (/ HOLDOSMODE HOLDECHO SS LST N A B X)
(setq HOLDECHO (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq HOLDOSMODE (getvar "osmode"))
(setvar "osmode" 0)
(setq SS (ssget "x"
(list '(0 . "CIRCLE") (cons 410 (getvar "ctab")))
)
N 0
)
(repeat (sslength SS)
(if (not
(member (setq CEN (cdr (assoc 10 (entget (ssname SS N)))))
LST
)
)
(setq LST (cons CEN LST))
)
(setq N (1+ N))
)
(setq A (* (getvar "CDATE") 1E8))
(mapcar '(lambda (X)
(while (progn (setq B (rtos (setq A (1+ A))))
(tblsearch "block" B)
)
)
(command
"_.block"
B
X
(ssget "X" (list '(0 . "CIRCLE") '(-4 . "=") (cons 10 X)))
""
)
(command "_.insert" B X "" "" "")
;(print B) ;注意:B可不是連續的!
)
LST
)
(command "_.erase" SS "")
(setvar "osmode" HOLDOSMODE)
(setvar "cmdecho" HOLDECHO)
(princ)
)

liyunlong

关注中

usercoolbo

谢谢龙龙仔了,小弟前些时候出差了,过会我试试!

无痕

考考大家。 难道没有写的更简单的么？或者其它的写法。 如果不是对全图 (ssget "X" (list '(0 . "CIRCLE") '(-4 . "=") (cons 10 X))) 怎么变通？

龙龙仔

如果不是对全图????你想说甚么?

雪山飞狐_lzh

这样么？

2. Public Sub test()
3. On Error Resume Next       Dim ft(0) As Integer, fd(0)
4.        Dim ss As AcadSelectionSet
5.        Dim Cols As New Collection
6.        Dim Objs As AcadBlock
7.        Dim pnt
8.        Dim strName As String
9.        Dim entitys(0) As AcadEntity
10.       
11.        ThisDrawing.SelectionSets("*TlsTest*").Delete
12.        Set ss = ThisDrawing.SelectionSets.Add("*TlsTest*")
13.        ft(0) = 0: fd(0) = "Circle"
14.        ss.Select acSelectionSetAll, , , ft, fd
15.       
16.        For Each i In ss
17.                pnt = i.Center
18.                strName = pnt(0) & "," & pnt(1) & "," & pnt(2)
19.                Err.Clear
20.                Set Objs = ThisDrawing.Blocks(Cols(strName))
21.                If Err Then
22.                        Set Objs = ThisDrawing.Blocks.Add(pnt, "*U")
23.                        Cols.Add Objs.Name, strName
24.                End If
25.                Set entitys(0) = i
26.                ThisDrawing.CopyObjects entitys, Objs
27.        Next i
28.       
29.        For Each i In Cols
30.                ThisDrawing.ModelSpace.InsertBlock ThisDrawing.Blocks(i).origin, i, 1, 1, 1, 0
31.        Next i
32.       
33.        ss.Erase
34.       
35. End Sub

Public Sub test() On Error Resume Next       Dim ft(0) As Integer, fd(0)        Dim ss As AcadSelectionSet        Dim Cols As New Collection        Dim Objs As AcadBlock        Dim pnt        Dim strName As String        Dim entitys(0) As AcadEntity               ThisDrawing.SelectionSets("*TlsTest*").Delete        Set ss = ThisDrawing.SelectionSets.Add("*TlsTest*")        ft(0) = 0: fd(0) = "Circle"        ss.Select acSelectionSetAll, , , ft, fd               For Each i In ss                pnt = i.Center                strName = pnt(0) & "," & pnt(1) & "," & pnt(2)                Err.Clear                Set Objs = ThisDrawing.Blocks(Cols(strName))                If Err Then                        Set Objs = ThisDrawing.Blocks.Add(pnt, "*U")                        Cols.Add Objs.Name, strName                End If                Set entitys(0) = i                ThisDrawing.CopyObjects entitys, Objs        Next i               For Each i In Cols                ThisDrawing.ModelSpace.InsertBlock ThisDrawing.Blocks(i).origin, i, 1, 1, 1, 0        Next i               ss.Erase        End Sub

cathyyu

sorry! 何为启动组？