[LISP程序]：明细表记录行（件号及其项目）自动删除

lsjjm

明细表记录行（件号及其项目）自动删除
用法：加载并运行程序，鼠标点击件号或件号所在行其他项目。
功能：删除指定行及明细表多余外框线；
      后续各行自动上下移动；
      件号自动重新排序；
      可自动识别表头上下位置。
适用于插入点为左上或左下角的属性块制作的明细表。
欢迎使用并提出意见。
[php]
(defun c:test (/ blk blkobj blkref rows cols atts pss txs)
  (vl-cmdf "ucs" "w" "")
  (setvar "osmode" 0)
  (vl-load-com)  
  (setq blk (entsel))
  (setq pat (cadr blk))
  (setq blk (car blk))
  (if (null blk)(progn (acet-ui-message "Block is not Selected" "SmartTool" 48)(quit)))
  (setq blkobj (vlax-ename->vla-object blk))
  (setq pins (vlax-get blkobj "insertionpoint"))
  (if (equal (cadr pins)(cadr (car (acet-geom-extents blk))) 0.0001)(setq up t))
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (setq blkref (vla-item (vla-get-blocks doc)(vla-get-name blkobj)))
  (vlax-for item blkref
    (cond
      ((= (vla-get-objectname item) "AcDbLine")
         (setq ps (vlax-get item "startpoint"))
         (setq pe (vlax-get item "endpoint"))
        (if (equal (cadr ps)(cadr pe) 0.001)
          (setq rows (cons (list ps pe item) rows))
          (setq cols (cons (list ps pe item) cols))
        ))
      ((= (vla-get-objectname item) "AcDbAttributeDefinition")
       (setq atts (cons item atts)))
    )
  )
  (setq rows (vl-sort rows '(lambda (p1 p2)(< (cadr (car p1))(cadr (car p2))))))
  (setq h (- (cadr (car (cadr rows)))(cadr (car (car rows)))) n 1)
  (if up (setq h (- h) rline (last (last rows))) (setq rline (last (car rows))))
  (vla-delete rline)
  (foreach i cols  ;;extend/trim vatical lines
    (if (or (and up (> (cadr (car i))(cadr (cadr i))))
            (and (null up)(< (cadr (car i))(cadr (cadr i)))))
      (vla-put-startpoint (last i)(vlax-3d-point (list (car (car i))
                                           (- (cadr (car i)) h)(last (car i)))))
      (vla-put-endpoint (last i)(vlax-3d-point (list (car (cadr i))
                               (+ (cadr (cadr i)) h)(last (cadr i)))))
    )
  );f
  (if (= (getvar "tilemode") 1)
    (setq space (vla-get-modelspace doc))
    (setq space (vla-get-paperspace doc))
  )
  (setq atts (reverse atts))
  (setq pat (mapcar '- pat pins))
  (foreach i atts
    (setq p (vlax-get i "textalignmentpoint"))
    (if (equal (cadr p)(cadr pat)(/ (abs h) 2))
      (progn
        (vla-delete i)
        (setq pss (append pss (list p)))
      )
    )
  )
  (setq pss (vl-sort pss '(lambda (p1 p2)(< (car p1)(car p2)))))
  (setq n (- n))
  (setq atts nil)
  (vlax-for item blkref
    (if (= (vla-get-objectname item) "AcDbAttributeDefinition")
       (setq atts (cons item atts))
    )
  )
  (foreach i atts       ;;move atts
    (setq p (vlax-get i "textalignmentpoint"))
    (if (or (and up (> (cadr p)(cadr pat)))
                (and (null up)(< (cadr p)(cadr pat))))
      (progn
        (vla-put-textalignmentpoint i (vlax-3d-point (list (car p)
                                                   (+ (cadr p) h)(last p))))
        (if (equal (car p)(car (car pss)) 0.001)
          (vla-put-textstring i (itoa (+ (atoi (vla-get-textstring i)) n)))
        )
      )
    )
  )
  (setq obj (vlax-ename->vla-object blk))
  (setq blkdef (vla-item (vla-get-blocks doc)(vla-get-name obj)))
  (vla-insertblock space (vlax-3d-point pins)(vla-get-name blkdef) 1 1 1 0)
  (vla-delete obj)
)
[/php]

luzuoji

支持！好好研究一下。