我用纯Lisp操作块

/db_自贡黄明儒_

我用纯Lisp操作块，实现了如下功能
[功能] 选择部分块重命名
[功能] 修改块插入基点
[功能] 块增加对象
[功能] 块遮罩

(vl-load-com)

;;[功能] 返回Text、 ATTdef的左下角点 左上角点  右上角点  右下角点
(defun _getTextBox (e / ANG BOX EN N P X Y Z)
  (setq en (entget e))
  (setq p (cdr (assoc 10 en)))
  (setq n (cdr (assoc 210 en)))
  (setq ang (cdr (assoc 50 en)))
  (setq box (_pnts:box (textbox en)))
  (setq        box
         ((lambda (z)
            (mapcar
              '(lambda (y) (mapcar '+ (mapcar '(lambda (x) (apply '+ (mapcar '* x y))) z) p))
              box
            )
          )
           (list (list (cos ang) (sin (- ang)) 0.0)
                 (list (sin ang) (cos ang) 0.0)
                 '(0.0 0.0 1.0)
           )
         )
  )
  (mapcar '(lambda (x) (trans x n 0)) box)
)


(Defun ATT-TEXT        (AENT / TENT ILIST INUM)
  (Setq TENT '((0 . "TEXT")))
  (ForEach INUM        '(8 6 38 39 62 67 210 10 40 1 50 41 51 7 71 72 73 11 74)
    (If        (Setq ILIST (Assoc INUM AENT))
      (Setq TENT (Cons ILIST TENT))
    )
  )
  (Setq tent (Subst (Cons 73 (item 74 aent)) (Assoc 74 tent) tent))
  (EntMake (Reverse TENT))
)

;;[功能] 块中属性角点
(Defun ATTpts (e / AENT ILIST OBJ PTS TENT)
  (setq AENT (entget e))
  (Setq TENT '((0 . "TEXT")))
  (ForEach INUM '(8 6 38 39 62 67 210 10 40 1 50 41 51 7 71 72 73 11)
    (If        (Setq ILIST (Assoc INUM AENT))
      (Setq TENT (Cons ILIST TENT))
    )
  )
  (Setq TENT (Subst (Cons 73 (CDR (Assoc 74 AENT))) (Assoc 72 TENT) TENT))
  (setq Obj (EntMakeX (Reverse TENT)))
  (setq pts (Entity:Box Obj))
  (entdel obj)
  pts
)

;;[功能] 取点函数,改造highflybird函数 2015.6.23 By 自贡黄明儒
;;(Graham-scan (HH:getpts (_BlockEle "ccd1")) 200))
;;(HH:getpts (_BlockEle "ccd1") 200)
(defun HH:getpts (Lst n / B DXF E S)
  (while
    (setq e (car Lst))
     (setq Lst (cdr Lst))
     (setq b (entget e))
     (setq dxf (cdr (assoc 0 b)))
     (cond
       ((= dxf "LWPOLYLINE")
        (setq s (append (get-pline-vertexs e n) s))
       )
       ((wcmatch dxf "SPLINE,ARC,CIRCLE,ELLIPSE")
        (setq s (append (get-spline-vertexs e n) s))
       )
       ((= dxf "LINE")
        (setq s (cons (cdr (assoc 10 b)) s))
        (setq s (cons (cdr (assoc 11 b)) s))
       )
       ((= dxf "POINT") (setq s (cons (cdr (assoc 10 b)) s)))
       ;;块中"ATTDEF"用"vla-getboundingbox"失败，转成text用textbox也不能解决
       ;;((= dxf "ATTDEF") (setq s (append (_pnts:box (ATTpts e)) s)))
       ;;((= dxf "ATTDEF") nil)
       ((wcmatch dxf "ATTDEF,TEXT") (setq s (append (_getTextBox e) s)))
       (T (setq s (append (_pnts:box (apply 'Entity:Box (list e))) s)))
     )
  )
  s
)
;;[功能] 取得样条曲线的点
;;(mapcar '(lambda(x) (command "line" x '(0 0) "")) (get-spline-vertexs (car(entsel)) 10))
;;改造适合圆、椭圆、弧(自贡黄明儒 2014.11.7)
(defun get-spline-vertexs (ent n / DIST ENDPAR LEN NAME OBJ PT PTS SEG)
  (setq obj (vlax-ename->vla-object ent))
  (setq endpar (vlax-curve-getEndParam obj))
  (setq len (vlax-curve-getDistAtParam obj endpar))
  (setq seg (/ len n))
  (setq dist 0)
  (while (< dist len)
    (setq pt (vlax-curve-getPointAtDist obj dist))
    (setq pts (cons pt pts))
    (setq dist (+ seg dist))
  )
  (setq Name (vlax-get obj 'ObjectName))
  ;;改造适合圆、椭圆、弧(自贡黄明儒 2014.11.7)
  (cond        ((and (equal Name "AcDbSpline")
              (= (vla-get-closed obj) :vlax-false)
         )
         (setq pt  (vlax-curve-getEndPoint obj)
               pts (cons pt pts)
         )
        )
        ;;((equal Name "AcDbSpline"))
  )
  (reverse pts)
)

;;[功能] 取得含有圆弧的多段线的点
;;(mapcar '(lambda(x) (command "line" x '(0 0) "")) (get-pline-vertexs (car(entsel)) 10))
;;n 为弧的取点数量
(defun get-pline-vertexs (ent n / BLG DIST ENDPAR I L1 L2 L3 LI OBJ PT PTS VEXNUM)
  (setq obj (vlax-ename->vla-object ent))
  (setq endpar (vlax-curve-getEndParam obj))
  (setq vexNum (fix endPar))
  (setq pts nil)
  (setq i 0)
  (repeat vexNum
    (setq pt (vlax-curve-getPointAtParam obj i))
    (setq pts (cons pt pts))
    (setq blg (vla-getbulge obj i))
    (if        (/= blg 0.0)
      (progn
        (setq l1 (vlax-curve-getDistAtParam obj i))
        (setq l2 (vlax-curve-getDistAtParam obj (1+ i)))
        (setq l3 (- l2 l1))                                    ;弧长
        (setq li (/ l3 n))
        (setq dist l1)
        (repeat        (1- n)
          (setq dist (+ dist li))
          (setq pt (vlax-curve-getPointAtDist obj dist))
          (setq pts (cons pt pts))
        )
      )
    )
    (setq i (1+ i))
  )
  (if (= (vla-get-closed obj) :vlax-false)
    (setq pt  (vlax-curve-getEndPoint obj)
          pts (cons pt pts)
    )
  )
  pts
)
;;[功能] 产生遮罩
;;(MyWipeout (list (getpoint)(getpoint)(getpoint)(getpoint)))
(defun MyWipeout (lst / A B P X Y)
  (setq lst (cons (last lst) lst))
  (setq p (apply 'mapcar (cons 'min lst)))
  (setq b (apply 'mapcar (cons 'max lst)))
  (setq b (apply 'max (mapcar '- b p)))
  (setq c (mapcar '+ p (list (* b 0.5) (* b 0.5))))
  (entmake
    (append
      (list '(000 . "WIPEOUT")
            '(100 . "AcDbEntity")
            '(100 . "AcDbWipeout")
            (cons 10 (trans p 1 0))
            (cons 11 (trans (list b 0.0) 1 0))
            (cons 12 (trans (list 0.0 b) 1 0))
            '(280 . 1)
            '(071 . 2)
      )
      (mapcar
        '(lambda (a)
          (cons 14 (mapcar '(lambda (x y z) (/ (- x y) z)) a c (list b (- b))))
         )
        lst
      )
    )
  )
)

;;[功能] 块图元列表
(defun _BlockEle (Name / E LST)
  (setq e (TBLOBJNAME "block" Name))
  (while (setq e (entnext e))
    (setq Lst (cons e Lst))
  )
  Lst
)

游客，如果您要查看本帖隐藏内容请回复

;;[功能] 选择部分块重命名
;;2015.6.13 By 自贡黄明儒
(defun C:PartBlockRename (/ EN N NEWNAME OLDNAME SS)
  (cond
    ((and (setq ss (ssget '((0 . "INSERT"))))
          (setq NewName (getstring "\n 输入新块名:"))
          (/= NewName "")
     )
     (setq oldName (cdr (assoc 2 (entget (ssname ss 0)))))     
     (_BlockNewName oldName NewName nil nil nil "")     
     (repeat (setq n (sslength ss))
       (setq en (entget (ssname ss (setq n (1- n)))))
       (entmod (subst (cons 2 NewName) (assoc 2 en) en))
     )         
    )
  )
  (princ)
)

;;[功能] 修改块插入基点
(defun C:ReInsertP (/ E EN N OBJ OLDNAME P P10 PT SS)
  (cond
    ((and (setq ss (ssget "_+.:E:S" '((0 . "INSERT"))))
          ;;(setq NewName (rtos (* (getvar "CDATE") 1E8)))
          (setq obj (vlax-ename->vla-object (ssname ss 0)))
          (setq oldName (vlax-get obj 'Name))
          (setq p (vlax-get obj 'InsertionPoint))
          (setq pt (getpoint p "\n块新基点"))
     )
     (setq pt (mapcar '- pt p))
     (_BlockNewName oldName nil pt nil nil "")     
     ;;使块原位不动
    (setq ss (ssget "X" (list '(0 . "INSERT") (cons 2 oldName))))
     (repeat (setq n (sslength ss))
       (entupd (setq e (ssname ss (setq n (1- n)))))
       (setq en (entget e))
       (setq p10 (mapcar '+ (cdr (assoc 10 en)) pt))
       (entmod (subst (cons 10 p10) (assoc 10 en) en))
     )
     ;;(command "_.move" ss "" "_non" p "_non" pt)
     ;;(command "_.purge" "_B" NewName "_N")
    )
  )
  (princ)
)

;;[功能] 块增加对象
(defun C:BlockAdd (/ E N OBJ OLDNAME P PT SS)
  (cond
    ((and (setvar "nomutt" 1)
          (princ "\n选择块：")
          (setq e (ssget "_+.:E:S" '((0 . "INSERT"))))
          (princ "\n增加入块对象：")
          (setq ss (ssget))
          (setvar "nomutt" 0)
     )
     ;;(setq NewName (rtos (* (getvar "CDATE") 1E8)))
     (setq obj (vlax-ename->vla-object (ssname e 0)))
     (setq oldName (vlax-get obj 'Name))
     (setq p (vlax-get obj 'InsertionPoint))
     (setq e (TBLOBJNAME "block" oldName))
     (setq pt (cdr (assoc 10 (entget e))))
     (command "_.move" ss "" "_non" p "_non" pt)
     (_BlockNewName oldName nil nil ss nil "")   
     ;;删除选择集
     (repeat (setq n (sslength ss))
       (entdel (ssname ss (setq n (1- n))))
     )
     ;;更新块
     (setq ss (ssget "X" (list '(0 . "INSERT") (cons 2 oldName))))
     (repeat (setq n (sslength ss))
       (entupd (ssname ss (setq n (1- n))))
     )
     ;;(command "_.move" ss "" "_non" p "_non" pt)
     ;;(command "_.purge" "_B" NewName "_N")
    )
  )
  (princ)
)

;;[功能] 块遮罩
(defun C:BlockMask (/ E N OBJ OLDNAME SS)
  (cond
    ((and (setvar "nomutt" 1)
          (princ "\n选择块：")
          (setq e (ssget "_+.:E:S" '((0 . "INSERT"))))
          (setvar "nomutt" 0)
     )
     ;;(setq NewName (rtos (* (getvar "CDATE") 1E8)))
     (setq obj (vlax-ename->vla-object (ssname e 0)))
     (setq oldName (vlax-get obj 'Name))   
     (_BlockNewName oldName nil nil nil T "")
     ;;更新块
     (setq ss (ssget "X" (list '(0 . "INSERT") (cons 2 oldName))))
     (command "_.DRAWORDER" ss "" "f");前置以便看到效果
     (repeat (setq n (sslength ss))
       (entupd (ssname ss (setq n (1- n))))
     )   
    )
  )
  (princ)
)

sachindkini

dear sir,


nice....

bbswen

学习学习，块操作

bbswen

请问下那个界面是怎么做的？代码里面没看到，

maker_lv

学习学习，强大啊{:soso_e179:}

wzg356

期待见到一个系列的

lucas3

大师, 两边跑 {:soso_e113:}

HLCAD

支持！支持！但见贴中含有许多QQ表情，影响阅读，望楼主重新修改一下

819534890

回复学习学习

天青色

谢谢楼主分享

liangxue918

nb！好好学习下~~

dwg001

非常好  ！

yoyoho

好好学习下!!!

杜流浪人

{:soso_e179:}{:soso_e160:}

zytyd

好好学习天天向上