我用纯Lisp操作块
本帖最后由 自贡黄明儒 于 2015-7-2 10:03 编辑我用纯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)
)
;;;desc:graham-scan算法计算点集凸包
;;;arg:ptlst:点表
;;;return:凸包点表
;;;example:(graham-scan '(pt1 pt2 pt3 ...))
(defun graham-scan (ptlst / d i p0)
(setq ptlst
(vl-sort
ptlst
'(lambda (p1 p2)
(cond
((< (cadr p1) (cadr p2)))
((equal (cadr p1) (cadr p2) 1e-8)
(< (car p1) (car p2))
)
)
)
)
) ;点集坐标排序
(setq p0 (car ptlst)) ;根据坐标排序结果选取Y值最小，同时X最小的点作为凸包的第一个点
(setq ptlst
(vl-sort
(cdr ptlst)
(function
(lambda (p1 p2 / m n)
(cond
((< (setq m (angle p1 p0)) (setq n (angle p2 p0))))
((equal m n 1e-8)
(< (distance p1 p0) (distance p2 p0))
)
)
)
)
)
) ;极角排序
;写凸包算法
(setq d (list (cadr ptlst) (car ptlst) p0)) ;构建初始凸包点集
(foreach curpt (cddr ptlst);遍历剩余点
(setq d (cons curpt d));当前点入栈
(while (and (caddr d) (isLeft (caddr d) (cadr d) curpt))
(setq d (cons curpt (cddr d))) ;判断这时候的凸包前三点是否左转，如果非左转，将第二点删除
)
)
) 块遮罩功能命令后出现 选择块：; 错误: no function definition: GRAHAM-SCAN 应该是少了GRAHAM-SCAN为函数 楼主能补上吗？ 水平不够，帮顶一下 顶顶顶顶顶一下 黄工出考题啦！ 需要一个矩阵转换 ivde 发表于 2015-6-27 00:13 static/image/common/back.gif
需要一个矩阵转换
“块遮罩”块内其它成员都不用矩阵转换，唯独Attdef需要转？ 也来学习一下 水平不够，帮顶一下 本帖最后由 userzhl 于 2015-6-27 18:36 编辑
缺少函数_PNTS:BOX