/db_自贡黄明儒_ 发表于 2015-7-15 12:48:48

我用纯Lisp操作块

本帖最后由 牢固 于 2015-7-20 14:06 编辑

我用纯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
)
**** Hidden Message *****

;;[功能] 选择部分块重命名
;;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 发表于 2015-7-15 13:33:28

dear sir,


nice....

bbswen 发表于 2015-7-15 14:07:38

学习学习,块操作

bbswen 发表于 2015-7-15 14:11:14

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

maker_lv 发表于 2015-7-15 15:31:36

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

wzg356 发表于 2015-7-15 17:55:00

期待见到一个系列的

lucas3 发表于 2015-7-15 18:00:05

大师, 两边跑 {:soso_e113:}

HLCAD 发表于 2015-7-15 18:13:34

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

819534890 发表于 2015-7-15 21:14:07


回复学习学习

天青色 发表于 2015-7-15 21:20:55

谢谢楼主分享

liangxue918 发表于 2015-7-16 13:01:50

nb!好好学习下~~

dwg001 发表于 2015-7-17 11:24:09

非常好!

yoyoho 发表于 2015-7-20 11:29:56

好好学习下!!!

杜流浪人 发表于 2015-7-20 14:27:03

{:soso_e179:}{:soso_e160:}

zytyd 发表于 2015-7-21 00:47:59

好好学习天天向上
页: [1] 2 3 4 5 6 7 8 9 10
查看完整版本: 我用纯Lisp操作块