找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 22536|回复: 216

[每日一码] 我用纯Lisp操作块

 火... [复制链接]

已领礼包: 604个

财富等级: 财运亨通

发表于 2015-7-15 12:48:48 | 显示全部楼层 |阅读模式

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

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

×
本帖最后由 牢固 于 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
)
游客,如果您要查看本帖隐藏内容请回复


;;[功能] 选择部分块重命名
;;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)
)
1.gif

评分

参与人数 1D豆 +5 收起 理由
xshrimp + 5 很给力!经验;技术要点;资料分享奖!

查看全部评分

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!

已领礼包: 1975个

财富等级: 堆金积玉

发表于 2015-7-15 13:33:28 | 显示全部楼层
dear sir,


nice....
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 75个

财富等级: 招财进宝

发表于 2015-7-15 14:07:38 | 显示全部楼层
学习学习,块操作
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 75个

财富等级: 招财进宝

发表于 2015-7-15 14:11:14 | 显示全部楼层
请问下那个界面是怎么做的?代码里面没看到,
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2015-7-15 15:31:36 | 显示全部楼层
学习学习,强大啊{:soso_e179:}
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2015-7-15 17:55:00 | 显示全部楼层
期待见到一个系列的
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 3198个

财富等级: 富可敌国

发表于 2015-7-15 18:00:05 | 显示全部楼层
大师, 两边跑 {:soso_e113:}
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 5578个

财富等级: 富甲天下

发表于 2015-7-15 18:13:34 | 显示全部楼层
支持!支持!但见贴中含有许多QQ表情,影响阅读,望楼主重新修改一下
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 2963个

财富等级: 家财万贯

发表于 2015-7-15 21:14:07 | 显示全部楼层

回复学习学习
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 651个

财富等级: 财运亨通

发表于 2015-7-15 21:20:55 | 显示全部楼层
谢谢楼主分享
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2015-7-16 13:01:50 | 显示全部楼层
nb!好好学习下~~
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 1个

财富等级: 恭喜发财

发表于 2015-7-17 11:24:09 | 显示全部楼层
非常好  !
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 8711个

财富等级: 富甲天下

发表于 2015-7-20 11:29:56 | 显示全部楼层
好好学习下!!!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 717个

财富等级: 财运亨通

发表于 2015-7-20 14:27:03 | 显示全部楼层
{:soso_e179:}{:soso_e160:}
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 1034个

财富等级: 财源广进

发表于 2015-7-21 00:47:59 | 显示全部楼层
好好学习天天向上
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-3-29 16:48 , Processed in 0.445972 second(s), 60 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表