块（包含属性块）边缘断线效果如何优化

magicheno

请教下大佬如下图功能，我通过拼凑出来的功能，就是先通过批量块缩放，把块缩放指定比例，在通过lee的程序把块内部区域的图元清空，在通过批量块缩放，恢复到之前比例。但是使用过程中感觉不是很流畅，特别是发现有不对的地方撤销（U）回去的时候，只能一个一个回，不能编组之后回，请教下大佬们这种该如何优化好呢，或者有其他新的想法的能实现这个效果的程序吗

我拼凑的程序如下
(defun c:kp( / *error* inc rot sel )
  (defun err(msg)
  (command-s ".UNDO" "E")
)
(setq *error* err)
  (command ".UNDO" "BE")
(defun *error* ( msg )
  (LM:endundo (LM:acdoc))
  (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
   (princ (strcat "\nError: " msg))
  )
  (princ)
)
(defun cen (en / MAXP MINP X Y)
  (vla-GetBoundingBox (vlax-ename->vla-object en) 'MinP 'MaxP)
  (setq MinP (vlax-safearray->list MinP))
  (setq MaxP (vlax-safearray->list MaxP))
  (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) MinP MaxP)
)   
(setq rot (= "ON" (getenv "LMac\\ABBRotation")))
(if (setq sel (ssget '((0 . "INSERT"))))           
  (progn
   (setq num (getreal "\n 缩放比例: "))
   (if (and num sel)
    (repeat (setq n (sslength sel))
     (setq en (ssname sel (setq n (1- n))))
     (vl-cmdf "_.scale" en "" (cen en) num)
    )
   )   
   (LM:startundo (LM:acdoc))
   (repeat (setq inc (sslength sel))
    (LM:AutoBlockBreak (ssname sel (setq inc (1- inc))) rot)
   )
   (LM:endundo (LM:acdoc))
   (if (and num sel)
    (repeat (setq n (sslength sel))
     (setq en (ssname sel (setq n (1- n))))   
     (vl-cmdf "_.scale" en "" (cen en) (/  1 num))
    )
   )      
  )
)
(command-s ".UNDO" "E")

(princ)
)
(defun LM:autoblockbreak ( ent rot / *error* _furthestapart ang bbx brk cmd crv di1 di2 enx idx ins int lst ply sel tmp )

(defun *error* ( msg )
  (if (and (= 'vla-object (type ply)) (vlax-write-enabled-p ply))
   (vla-delete ply)
  )
  (if (= 'int (type cmd))
   (setvar 'cmdecho cmd)
  )
  (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
   (princ (strcat "\nError: " msg))
  )
  (princ)
)

(defun _furthestapart ( lst / dis mxd out pt1 pt2 )
  (setq mxd 0.0)
  (while (setq pt1 (car lst))
   (foreach pt2 (setq lst (cdr lst))
    (if (< mxd (setq dis (distance pt1 pt2)))
     (setq mxd dis
      out (list pt1 pt2)
     )
    )
   )
  )
  out
)
  
(if (and (= 'ename (type ent))
    (setq enx (entget ent))
    (= "INSERT" (cdr (assoc 0 enx)))
   )
  (progn
   (if
    (and
     rot
     (setq bbx (LM:blockboundingbox (vlax-ename->vla-object ent)))
     (setq sel
      (ssget "_C"
       (trans (car   bbx) 0 1)
       (trans (caddr bbx) 0 1)
       '((0 . "ARC,ELLIPSE,CIRCLE,LINE,XLINE,SPLINE,*POLYLINE"))
      )
     )
     (progn
      (setq ins (trans (cdr (assoc 10 enx)) ent 0)
       crv (ssname sel (1- (sslength sel)))
       di1 (distance ins (vlax-curve-getclosestpointto crv ins))
      )
      (repeat (setq idx (1- (sslength sel)))
       (setq tmp (ssname sel (setq idx (1- idx))))
       (if (< (setq di2 (distance ins (vlax-curve-getclosestpointto tmp ins))) di1)
        (setq di1 di2
         crv tmp
        )
       )
      )
      (< di1 1e-4)
     )
     (setq par (vlax-curve-getparamatpoint crv (vlax-curve-getclosestpointto crv ins)))
     (cond
      (   (equal par (vlax-curve-getendparam crv) 1e-8)
       (setq  par (vlax-curve-getparamatdist crv (- (vlax-curve-getdistatparam crv par) 1e-3)))
      )
      (   (equal par (vlax-curve-getstartparam crv) 1e-8)
       (setq  par (vlax-curve-getparamatdist crv (+ (vlax-curve-getdistatparam crv par) 1e-3)))
      )
      (   t   )
     )
     (setq der (vlax-curve-getfirstderiv crv par))
     (setq ang (angle '(0.0 0.0 0.0) (trans der 0 (cdr (assoc 210 (entget crv))))))
     (or (<= ang (/ pi 2.0))
      (< (/ (* 3.0 pi) 2.0) ang)
      (setq ang (+ ang pi))
     )
    )
    (vla-put-rotation (vlax-ename->vla-object ent) ang) ;; VL used to account for attributes
   )
   (if
    (and
     (setq bbx (LM:blockboundingbox (vlax-ename->vla-object ent)))
     (setq sel
      (ssget "_C"
       (trans (car   bbx) 0 1)
       (trans (caddr bbx) 0 1)
       '((0 . "ARC,ELLIPSE,CIRCLE,LINE,XLINE,SPLINE,*POLYLINE"))
      )
     )
    )
    (progn
     (setq ply
      (vlax-ename->vla-object
       (entmakex
        (append
         (list
          '(000 . "LWPOLYLINE")
          '(100 . "AcDbEntity")
          '(100 . "AcDbPolyline")
          '(090 . 4)
          '(070 . 1)
          (cons 38 (cadddr (assoc 10 enx)))
         )
         (mapcar '(lambda ( p ) (mapcar '+ (cons 10 (trans p 0 ent)) '(0 0 0))) bbx)
         (list (assoc 210 enx))
        )
       )
      )
     )
     (repeat (setq idx (sslength sel))
      (setq ent (ssname sel (setq idx (1- idx))))
      (if (setq int (LM:Intersections (vlax-ename->vla-object ent) ply acextendthisentity))
       (setq lst (cons (cons ent int) lst))
      )
     )
     (vla-delete ply)
     (setq cmd (getvar 'cmdecho))
     (setvar 'cmdecho 0)
     (foreach int lst
      (if (setq brk (_furthestapart (cdr int)))
       (command
        "_.break" (list  (car int) (trans (car brk) 0 1)) "_F"
        "_non"    (trans (car  brk) 0 1)
        "_non"    (trans (cadr brk) 0 1)
       )
      )
     )
     (setvar 'cmdecho cmd)
    )
   )
  )
)
(princ)
)
;; Intersections  -  Lee Mac
;; Returns a list of all points of intersection between two objects.
;; obj1,obj2 - [vla] VLA-Objects with intersectwith method applicable
;; mode      - [int] acextendoption enum of intersectwith method
;; Returns: [lst] List of 3D WCS intersection points, else nil
(defun LM:intersections ( obj1 obj2 mode / l r )
(setq l (vlax-invoke obj1 'intersectwith obj2 mode))
(repeat (/ (length l) 3)
  (setq r (cons (list (car l) (cadr l) (caddr l)) r)
   l (cdddr l)
  )
)
(reverse r)
)
(defun LM:blockboundingbox ( blk / bnm llp lst urp )
(setq bnm (strcase (vla-get-name blk)))
(cond
  (   (setq lst (cdr (assoc bnm LM:blockboundingbox:cache))))
  (   (progn
     (vlax-for obj (vla-item (LM:acblk) bnm)
      (cond
       (   (= "AcDbBlockReference" (vla-get-objectname obj))
        (setq lst (append lst (LM:blockboundingbox obj)))
       )
       (   (and
          (= :vlax-true (vla-get-visible obj))
          (not (wcmatch (vla-get-objectname obj) "AcDbAttributeDefinition,AcDb*Text"))
          (vlax-method-applicable-p obj 'getboundingbox)
          (= :vlax-false (vla-get-freeze (vla-item (LM:aclyr) (vla-get-layer obj))))
          (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
         )
        (setq lst (vl-list* (vlax-safearray->list llp) (vlax-safearray->list urp) lst))
       )
      )
     )
     lst
    )
   (setq lst (mapcar '(lambda ( fun ) (apply 'mapcar (cons fun lst))) '(min max)))
   (setq lst
    (list
     (car lst)
     (list (caadr lst) (cadar lst))
     (cadr lst)
     (list (caar lst) (cadadr lst))
    )
   )
   (setq LM:blockboundingbox:cache (cons (cons bnm lst) LM:blockboundingbox:cache))
  )
)
(apply
  (function
   (lambda ( m v )
    (mapcar (function (lambda ( p ) (mapcar '+ (mxv m p) v))) lst)
   )
  )
  (refgeom (vlax-vla-object->ename blk))
)
)
;; RefGeom (gile)
;; Returns a list which first item is a 3x3 transformation matrix (rotation,
;; scales, normal) and second item the object insertion point in its parent
;; (xref, block or space)
;;
;; Argument : an ename
(defun refgeom ( ent / ang ang mat ocs )
(setq enx (entget ent)
  ang (cdr (assoc 050 enx))
  ocs (cdr (assoc 210 enx))
)
(list
  (setq mat
   (mxm
    (mapcar '(lambda ( v ) (trans v 0 ocs t))
     '(
       (1.0 0.0 0.0)
       (0.0 1.0 0.0)
       (0.0 0.0 1.0)
      )
    )
    (mxm
     (list
      (list (cos ang) (- (sin ang)) 0.0)
      (list (sin ang) (cos ang)     0.0)
      '(0.0 0.0 1.0)
     )
     (list
      (list (cdr (assoc 41 enx)) 0.0 0.0)
      (list 0.0 (cdr (assoc 42 enx)) 0.0)
      (list 0.0 0.0 (cdr (assoc 43 enx)))
     )
    )
   )
  )
  (mapcar '- (trans (cdr (assoc 10 enx)) ocs 0)
   (mxv mat (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx))))))
  )
)
)
;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
;; Matrix Transpose - Doug Wilson
;; Args: m - nxn matrix
(defun trp ( m )
(apply 'mapcar (cons 'list m))
)
;; Matrix x Matrix - Vladimir Nesterovsky
;; Args: m,n - nxn matrices
(defun mxm ( m n )
((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)
;; Block Name  -  Lee Mac
;; Returns the true (effective) name of a supplied block reference
(defun LM:blockname ( obj )
(if (vlax-property-available-p obj 'effectivename)
  (defun LM:blockname ( obj ) (vla-get-effectivename obj))
  (defun LM:blockname ( obj ) (vla-get-name obj))
)
(LM:blockname obj)
)
;; Start Undo  -  Lee Mac
;; Opens an Undo Group.
(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)
;; End Undo  -  Lee Mac
;; Closes an Undo Group.
(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
  (vla-endundomark doc)
)
)
;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object
(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)
;; Block Collection  -  Lee Mac
;; Returns the VLA Block Collection Object
(defun LM:acblk nil
(eval (list 'defun 'LM:acblk 'nil (vla-get-blocks (LM:acdoc))))
(LM:acblk)
)
;; Layer Collection  -  Lee Mac
;; Returns the VLA Layer Collection Object
(defun LM:aclyr nil
(eval (list 'defun 'LM:aclyr 'nil (vla-get-layers (LM:acdoc))))
(LM:aclyr)
)
;;----------------------------------------------------------------------;;
(if (null (getenv "LMac\\ABBRotation"))
(setenv "LMac\\ABBRotation" "ON")
)
;;----------------------------------------------------------------------;;

xyp1964

可以试试用：图块遮蔽

magicheno

xyp1964 发表于 2022-2-26 12:52
可以试试用：图块遮蔽

图块遮罩不太好了，会把底图内容全部遮住，图纸没法看了的

guosheyang

是这样吗，将块儿内的线删除不 将你的代码简化  将 abb有命令改为函数即可

magicheno

guosheyang 发表于 2022-2-26 16:29
是这样吗，将块儿内的线删除不 将你的代码简化  将 abb有命令改为函数即可

主要是还有放大，在打断的，还有就是撤回不能编组撤回的呢

guosheyang

编组那个我弄出来也不行

magicheno

guosheyang 发表于 2022-2-26 20:19
编组那个我弄出来也不行

是的不知道为啥呢，U回去的时候太折腾了

guosheyang

本帖的一种局部优化提速办法在这儿  http://bbs.mjtd.com/thread-184837-1-1.html

hao3ren

遮罩方便后期改图

magicheno

guosheyang 发表于 2022-2-26 21:50
本帖的一种局部优化提速办法在这儿  http://bbs.mjtd.com/thread-184837-1-1.html

感谢大佬优化