[分享]：选择集转块方法收集

taner · 发表于 2009-2-14 11:25:45

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

[FONT=courier new]
;;; 选择集转块的方法
;;; ==================================================================
;;; 以下两个为俺在国外的网站上找到的,具体地址不记得了.
(defun th-ss2blk
(selset inspoint blkname / array block index objlstofss ss)
(setq block (vla-add (vla-get-blocks (thactdoc))
(vlax-3d-point inspoint)
blkname
)
objlstofss (hao-ss2objlst selset)
index (1- (sslength selset))
array (vlax-safearray-fill
(vlax-make-safearray
vlax-vbobject
(cons 0 index)
)
objlstofss
)
)
(vla-copyobjects (thactdoc) array block)
(mapcar
'vla-delete
objlstofss
)
(vla-insertblock
(thactsp)
(vlax-3d-point inspoint)
(vla-get-name block)
1
1
1
0
)
)
(defun hao-ss2blk
(selset inspoint blkname / array block index objlstofss)
(setq block (vla-add (vla-get-blocks (thactdoc))
(vlax-3d-point inspoint)
blkname
)
objlstofss (hao-ss2objlst selset)
index (1- (sslength selset))
array (vlax-make-safearray vlax-vbobject (cons 0 index))
)
(foreach each objlstofss
(vlax-safearray-put-element array index each)
(setq index (1- index))
)
(vla-copyobjects (thactdoc) array block)
(mapcar
'vla-delete
objlstofss
)
(vla-insertblock
(thactsp)
(vlax-3d-point inspoint)
(vla-get-name block)
1
1
1
0
)
)
(defun t2-ss2blk (ss pt bn)
(entmake
(list (cons 0 "BLOCK") (cons 10 pt) (cons 2 bn) '(70 . 0))
)
(foreach each (hao-ss2lst ss)
(setq elist (entget each))
(entmake elist)
)
(entmake (list (cons 0 "ENDBLK")))
(entmake (list (cons 0 "INSERT") (cons 2 bn) (cons 10 pt)))
(command "_.ERASE" ss "")
(redraw)
(princ)
)
;;; ==================================================================
;;; 选择集转随机名的块
(defun th-rnd-block (ss pt / blk name)
(setq blk t)
(while blk
(if (null (tblobjname "block" (setq name (rtos (th-rnd)))))
(progn
(command "-block" name "non" pt ss "")
(setq blk nil)
)
)
)
(command "-insert" name pt "" "" "")
(princ)
)
(defun hao-rnd-block (ss pt / blk name)
(setq blk t)
(while blk
(if (null (tblobjname "block" (setq name (rtos (th-rnd)))))
(progn
(th-ss2blk ss pt name)
(setq blk nil)
)
)
)
)
(defun t2-rnd-block (ss pt)
(vl-cmdf "cutclip" ss "")
(vl-cmdf "pasteblock" "non" pt)
(princ)
)
;;; 这个与上面两个不同,pt需为ss最小包围角左下角时,生成的块位置才与ss重合
;;; ==================================================================
;;; [url]http://www.xdcad.net/forum/showthread.php?s=&threadid=456502[/url]
;;; 上面的链接为eachy版主的块制函数,俺改了一下,不知道对不,目前测试可用.
;;; 制作做块头
(defun th-mkblk (blockname pt / blocktype)
(if (or
(/= 'str (type blockname))
(= "" blockname)
)
(setq blockname "*A")
)
(if (= (substr blockname 1 1) "*")
(setq blocktype 1
blockname "*A"
)
(setq blocktype 0)
)
(entmake (list '(0 . "BLOCK")
(cons 2 blockname)
(cons 70 blocktype)
(cons 10 pt)
)
)
)
;;; 做块尾
(defun th-mkeblk ()
(entmake '((0 . "ENDBLK")))
)
;;; 插入图块
(defun th-mkinsert (bname ins-pt)
(entmakex
(list '(0 . "INSERT") (cons 2 bname) (cons 10 ins-pt))
)
)
;;; 在此基础上,再生成一个函数
(defun th-block (bn pt lambda-expression)
(th-mkblk bn pt)
(lambda-expression)
(setq bn (th-mkeblk))
(th-mkinsert bn pt)
)
;;; ==================================================================
[/FONT]

[FONT=courier new] 
 
;;; 选择集转块的方法 
;;; ================================================================== 
;;; 以下两个为俺在国外的网站上找到的,具体地址不记得了. 
(defun th-ss2blk 
       (selset inspoint blkname / array block index objlstofss ss) 
  (setq        block           (vla-add (vla-get-blocks (thactdoc)) 
                            (vlax-3d-point inspoint) 
                            blkname 
                   ) 
        objlstofss (hao-ss2objlst selset) 
        index           (1- (sslength selset)) 
        array           (vlax-safearray-fill 
                     (vlax-make-safearray 
                       vlax-vbobject 
                       (cons 0 index) 
                     ) 
                     objlstofss 
                   ) 
  ) 
  (vla-copyobjects (thactdoc) array block) 
  (mapcar 
    'vla-delete 
    objlstofss 
  ) 
  (vla-insertblock 
    (thactsp) 
    (vlax-3d-point inspoint) 
    (vla-get-name block) 
    1 
    1 
    1 
    0 
  ) 
) 
(defun hao-ss2blk 
       (selset inspoint blkname / array block index objlstofss) 
  (setq        block           (vla-add (vla-get-blocks (thactdoc)) 
                            (vlax-3d-point inspoint) 
                            blkname 
                   ) 
        objlstofss (hao-ss2objlst selset) 
        index           (1- (sslength selset)) 
        array           (vlax-make-safearray vlax-vbobject (cons 0 index)) 
  ) 
  (foreach each        objlstofss 
    (vlax-safearray-put-element array index each) 
    (setq index (1- index)) 
  ) 
  (vla-copyobjects (thactdoc) array block) 
  (mapcar 
    'vla-delete 
    objlstofss 
  ) 
  (vla-insertblock 
    (thactsp) 
    (vlax-3d-point inspoint) 
    (vla-get-name block) 
    1 
    1 
    1 
    0 
  ) 
) 
(defun t2-ss2blk (ss pt bn) 
  (entmake 
    (list (cons 0 "BLOCK") (cons 10 pt) (cons 2 bn) '(70 . 0)) 
  ) 
  (foreach each        (hao-ss2lst ss) 
    (setq elist (entget each)) 
    (entmake elist) 
  ) 
  (entmake (list (cons 0 "ENDBLK"))) 
  (entmake (list (cons 0 "INSERT") (cons 2 bn) (cons 10 pt))) 
  (command "_.ERASE" ss "") 
  (redraw) 
  (princ) 
) 
;;; ================================================================== 
;;; 选择集转随机名的块 
(defun th-rnd-block (ss pt / blk name) 
  (setq blk t) 
  (while blk 
    (if        (null (tblobjname "block" (setq name (rtos (th-rnd))))) 
      (progn 
        (command "-block" name "non" pt ss "") 
        (setq blk nil) 
      ) 
    ) 
  ) 
  (command "-insert" name pt "" "" "") 
  (princ) 
) 
(defun hao-rnd-block (ss pt / blk name) 
  (setq blk t) 
  (while blk 
    (if        (null (tblobjname "block" (setq name (rtos (th-rnd))))) 
      (progn 
        (th-ss2blk ss pt name) 
        (setq blk nil) 
      ) 
    ) 
  ) 
) 
(defun t2-rnd-block (ss pt) 
  (vl-cmdf "cutclip" ss "") 
  (vl-cmdf "pasteblock" "non" pt) 
  (princ) 
) 
;;; 这个与上面两个不同,pt需为ss最小包围角左下角时,生成的块位置才与ss重合 
;;; ================================================================== 
;;; [url]http://www.xdcad.net/forum/showthread.php?s=&threadid=456502[/url] 
;;; 上面的链接为eachy版主的块制函数,俺改了一下,不知道对不,目前测试可用. 
;;; 制作做块头 
(defun th-mkblk        (blockname pt / blocktype) 
  (if (or 
        (/= 'str (type blockname)) 
        (= "" blockname) 
      ) 
    (setq blockname "*A") 
  ) 
  (if (= (substr blockname 1 1) "*") 
    (setq blocktype 1 
          blockname "*A" 
    ) 
    (setq blocktype 0) 
  ) 
  (entmake (list '(0 . "BLOCK") 
                 (cons 2 blockname) 
                 (cons 70 blocktype) 
                 (cons 10 pt) 
           ) 
  ) 
) 
;;; 做块尾 
(defun th-mkeblk () 
  (entmake '((0 . "ENDBLK"))) 
) 
;;; 插入图块 
(defun th-mkinsert (bname ins-pt) 
  (entmakex 
    (list '(0 . "INSERT") (cons 2 bname) (cons 10 ins-pt)) 
  ) 
) 
;;; 在此基础上,再生成一个函数 
(defun th-block        (bn pt lambda-expression) 
  (th-mkblk bn pt) 
  (lambda-expression) 
  (setq bn (th-mkeblk)) 
  (th-mkinsert bn pt) 
) 
;;; ================================================================== 
 
  [/FONT]

相关公共函数

[FONT=courier new]
;;; ==================================================================
;;; 子函数
(defun hao-ss2lst (ss / n l)
(if (and
ss
(< 0 (sslength ss))
)
(repeat (setq n (sslength ss))
(setq n (1- n)
l (cons (ssname ss n) l)
)
)
)
)
(defun hao-ss2objlst (ss / n l)
(if (and
ss
(< 0 (sslength ss))
)
(repeat (setq n (sslength ss))
(setq n (1- n)
l (cons (vlax-ename->vla-object (ssname ss n)) l)
)
)
)
)
(defun thacadobj ()
(cond
(%$*thacadobj*$%)
(setq %$*thacadobj*$% (vlax-get-acad-object))
)
)
(defun thactdoc ()
(cond
(%$*thactdoc*$%)
(setq %$*thactdoc*$% (vla-get-activedocument (thacadobj)))
)
)
(defun th-rnd ()
(* (rem (* (getvar "cputicks") (getvar "millisecs")) 1e8) 1e-8)
)
(defun hao-ss-aftere (ename / ss)
(if (and
ename
(setq ss (ssadd))
(eq 'ename (type ename))
)
(while (setq ename (entnext ename))
(ssadd ename ss)
)
(setq ss (ssget "x"))
)
ss
)
;;; ==================================================================
[/FONT]

[FONT=courier new] 
;;; ================================================================== 
;;; 子函数 
(defun hao-ss2lst (ss / n l) 
  (if (and 
        ss 
        (< 0 (sslength ss)) 
      ) 
    (repeat (setq n (sslength ss)) 
      (setq n (1- n) 
            l (cons (ssname ss n) l) 
      ) 
    ) 
  ) 
) 
(defun hao-ss2objlst (ss / n l) 
  (if (and 
        ss 
        (< 0 (sslength ss)) 
      ) 
    (repeat (setq n (sslength ss)) 
      (setq n (1- n) 
            l (cons (vlax-ename->vla-object (ssname ss n)) l) 
      ) 
    ) 
  ) 
) 
(defun thacadobj () 
  (cond 
    (%$*thacadobj*$%) 
    (setq %$*thacadobj*$% (vlax-get-acad-object)) 
  ) 
) 
(defun thactdoc () 
  (cond 
    (%$*thactdoc*$%) 
    (setq %$*thactdoc*$% (vla-get-activedocument (thacadobj))) 
  ) 
) 
(defun th-rnd () 
  (* (rem (* (getvar "cputicks") (getvar "millisecs")) 1e8) 1e-8) 
) 
(defun hao-ss-aftere (ename / ss) 
  (if (and 
        ename 
        (setq ss (ssadd)) 
        (eq 'ename (type ename)) 
      ) 
    (while (setq ename (entnext ename)) 
      (ssadd ename ss) 
    ) 
    (setq ss (ssget "x")) 
  ) 
  ss 
) 
;;; ================================================================== 
  [/FONT]

应用

[FONT=courier new]
;;; ==================================================================
(defun c:test1 (/ elist ss)
(th-block "th"
(getpoint "\nPick point:")
(lambda ()
(setq ss (ssget))
(foreach each
(hao-ss2lst ss)
(setq elist (entget each))
(entmake elist)
)
)
)
)
(defun c:test2 ( / elist laste pt ss)
(th-block ""
(getpoint "\nPick point:")
(lambda ()
(setq laste (entlast))
(command "line"
(getpoint "\nPick point:")
(getpoint "\nPick next point:")
""
)
(command "circle"
(getpoint "\nPick point:")
5
)
(command "line"
(getpoint "\nPick point:")
(getpoint "\nPick next point:")
""
)
(command "circle"
(setq pt(getpoint "\nPick point:"))
(getdist pt "\nPick next poiont:")
)
(setq ss (hao-ss-aftere laste))
(foreach each
(hao-ss2lst ss)
(setq elist (entget each))
(entmake elist)
)
(command "erase" ss "")
)
)
)
;;; ==================================================================
[/FONT]

[FONT=courier new] 
;;; ================================================================== 
(defun c:test1 (/ elist ss) 
  (th-block "th" 
            (getpoint "\nPick point:") 
            (lambda () 
              (setq ss (ssget)) 
              (foreach each 
                            (hao-ss2lst ss) 
                (setq elist (entget each)) 
                (entmake elist) 
              ) 
            ) 
  ) 
) 
(defun c:test2 ( / elist laste pt ss) 
  (th-block "" 
            (getpoint "\nPick point:") 
            (lambda () 
              (setq laste (entlast)) 
              (command "line" 
                       (getpoint "\nPick point:") 
                       (getpoint "\nPick next point:") 
                       "" 
              ) 
              (command "circle" 
                       (getpoint "\nPick point:") 
                       5 
              ) 
              (command "line" 
                       (getpoint "\nPick point:") 
                       (getpoint "\nPick next point:") 
                       "" 
              ) 
              (command "circle" 
                       (setq pt(getpoint "\nPick point:")) 
                       (getdist pt "\nPick next poiont:") 
              ) 
              (setq ss (hao-ss-aftere laste)) 
              (foreach each 
                            (hao-ss2lst ss) 
                (setq elist (entget each)) 
                (entmake elist) 
              ) 
              (command "erase" ss "") 
            ) 
  ) 
) 
;;; ================================================================== 
  [/FONT]

firstintimate · 发表于 2009-2-14 11:40:36

谢谢taner分享

雄啸 · 发表于 2009-2-14 15:08:01

最简单的 ctrl+<shift>+c, ctrl+v

TYEEXDD · 发表于 2009-2-14 18:26:39

老外真能整，整出这么长的代码来......
俺都没耐心看下去......3楼说的多好！

xyp1964 · 发表于 2009-2-14 19:36:00

[FONT=courier new]
;; 建立随机名图块
(defun Rand-Block (ss point / x)
(setq x (rtos (* (getvar "cdate") 1000000) 2 0))
(command "_block" x "non" point ss "")
(command "_insert" x "non" point "" "" "")
)[/FONT]

xyp1964 · 发表于 2009-2-14 19:39:05

[FONT=courier new];; 建立图块
(defun Rand-Block (bname ss point / x)
(command "_block" bname "non" point ss "")
(command "_insert" bname "non" point "" "" "")
)[/FONT]

TLHMQH · 发表于 2009-2-14 22:40:37

xyp1964
为什么对你的函数加载时总是显示“错误: 参数太少”

hhjj9898 · 发表于 2009-2-21 14:43:53

同意7楼的意见

fflsnow · 发表于 2009-2-24 13:02:39

是啊,简单就是最好的!

qxlonmsn · 发表于 2022-7-8 14:51:14

感谢分享!这个有用

hh_lj007 · 发表于 2022-7-14 10:06:53

感谢分享源码和讨论

账号		自动登录	找回密码
密码			立即注册

[分享]：选择集转块方法收集

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子