我用纯Lisp操作块

自贡黄明儒

我用纯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
)
;;[功能] 定义一个新块(NewName可以是存在的块名,也可以是oldName)
;;ss是点表时产生遮罩,对象词典70组码wipeout边框,13版以后的系统变量WIPEOUTFRAME
(defun _BlockNewName (oldName NewName pt SS Mask desc / E EN L1 L2 L3 N P10 S)
  (setq e (TBLOBJNAME "block" oldName))
  (setq en (entget e))
  ;;没有描述则增加
  (cond
    ((and desc (= (type desc) 'STR) (assoc 4 en))
     (setq en (subst (cons 4 desc) (assoc 4 en) en))
    )
    ((= (type desc) 'STR) (setq en (append en (list (cons 4 desc)))))
  )
  (cond ((not NewName) (setq NewName oldName)))
  (setq en (subst (cons 2 NewName) (assoc 2 en) en))
  ;;改基点
  (cond
    (pt
     (setq p10 (mapcar '+ (cdr (assoc 10 en)) pt))
     (setq en (subst (cons 10 p10) (assoc 10 en) en))
    )
  )
  (setq l1 en)
  (while (setq e (entnext e)) (setq l3 (cons e l3)))
  (cond
    ((= (type ss) 'PICKSET)                                    ;块增加对象
     (repeat (setq n (sslength ss))
       (setq l2 (cons (ssname ss (setq n (1- n))) l2))
     )
    )
  )

  (entmake l1)                                                    ;定义块头  
  (cond
    (Mask
     (setq s (HH:getpts (_BlockEle NewName) 200));(HH:getpts (_BlockEle "CCD1") 200)
     (cond (ss (setq s (append (HH:getpts l2 200) s))))
     (MyWipeout (Graham-scan s))                            ;用高飞扫锚程序
    )
  )
  (cond (ss (foreach x l2 (entmake (entget x)))))
  (foreach x l3 (entmake (entget x)))
  (entmake '((0 . "ENDBLK")))                                    ;定义块尾
)

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

alexmai

;;;desc:graham-scan算法计算点集凸包
;;;arg:ptlst:点表
;;;return:凸包点表
;;;examplegraham-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))) ;判断这时候的凸包前三点是否左转，如果非左转，将第二点删除
    )
  )
)

stonedesign

块遮罩功能  命令后出现   选择块：; 错误: no function definition: GRAHAM-SCAN   应该是少了GRAHAM-SCAN为函数   楼主能补上吗？

伪书虫86

水平不够，帮顶一下

cable2004

顶顶顶顶顶一下

434939575

黄工出考题啦！

ivde

需要一个矩阵转换

自贡黄明儒

ivde 发表于 2015-6-27 00:13
需要一个矩阵转换

“块遮罩”块内其它成员都不用矩阵转换，唯独Attdef需要转？

spp_wall

Jack_PC

也来学习一下

用户3766035971

水平不够，帮顶一下

userzhl

缺少函数_PNTS:BOX