[LISP程序]：自动添加明细表件号项（记录行）

lsjjm

自动添加明细表件号项（记录行）
用法：加载并运行程序，鼠标点击件号或件号所在行其他项目。
功能：在指定行上下（前后）添加新的件号及其项目及明细表外框线；
后续各行自动上下移动；
件号自动重新排序；
可自动识别表头上下位置。
适用于插入点为左上或左下角的属性块制作的明细表。
欢迎使用并提出意见。
[PHP]
26/11/04
(defun c:testa (/ blk pat blkobj pins doc blkref up
                  ps pe rows cols atts h n rline space p 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.001)(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 (null up)(setq h (- h)))
  (if up (setq rline (last (last rows)))(setq rline (last (car rows))))
  (vla-copy rline)
  (vla-move rline (vlax-3d-point '(0 0 0))(vlax-3d-point (list 0 h 0)))
  (foreach i cols
    (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))
      (setq pss (append pss (list p))
            txs (append txs (list (vla-get-textstring i))))
    )
  )
  (setq pss (vl-sort pss '(lambda (p1 p2)(< (car p1)(car p2)))))
  (setq atts nil)
  (vlax-for item blkref
    (if (= (vla-get-objectname item) "AcDbAttributeDefinition")
      (setq atts (cons item atts))
    )
  )
  (foreach i 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 ntag (* (- (length rows) 2)(1- (length cols))))
  (setq   tt (list "" "\nPart Number: " "\nDrawing Number: " "\nQuantity: "))
  (setq  lay (vla-get-layer (car atts))
         col (vla-get-color (car atts))
          th (vla-get-height (car atts))
         sty (vla-get-stylename (car atts)))
  (setvar "clayer" lay)
  (setvar "cecolor" (itoa col))
  (setq i 0)
  (while (< i (length pss))
    (setq ipt (list (car (nth i pss))(+ (cadr (nth i pss)) h)(last (nth i pss))))
    (if (= i 0)
      (setq tn (1+ ntag) num (itoa (1+ (atoi (car txs)))))
      (setq tn (+ ntag 1 i) num (strcase (getstring (nth i tt))))
    )
    (setq obj (vlax-ename->vla-object blk))
    (setq blkdef (vla-item (vla-get-blocks doc)(vla-get-name obj)))
    (setq  ipt (vlax-3d-point ipt))
    (setq attdef (vla-addattribute blkdef th acAttributeModeverify ""
                            ipt (strcat "T" (itoa tn)) num))
    (vla-put-alignment attdef 10)
    (vla-put-stylename attdef sty)
    (vla-put-textalignmentpoint attdef ipt)
    (vla-insertblock space (vlax-3d-point pins)(vla-get-name blkdef) 1 1 1 0)
    (vla-delete obj)
    (setq blk (entlast))
    (setq i (1+ i))
  )  
)
[/PHP]

cyxzime

不行

ljs026

不能用耶

lsjjm

2楼，3楼：怎么个不行？不能用法？请详细说明？

LUCAS

2. 
   
3. ;;沒有測試圖及使用說明!
   
4.   (arxload "acetutil.arx" NIL)                ;LUCAS
   
5.   (vl-cmdf "ucs" "w")                        ; "");LUCAS
   
6.   (setvar "osmode" 0)
   
7.   (vl-load-com)
   
8.   (setq BLK (entsel));選甚麼??帶屬性BLOCK??附圖較好!
   
9.   (setq PAT (cadr BLK))
   
10.   (setq BLK (car BLK))
    
11.   (if (null BLK)
    
12.     (progn (acet-ui-message "Block is not Selected" "SmartTool" 48)
    
13.            (quit)
    
14.     )
    
15.   )
    
16.   (setq BLKOBJ (vlax-ename->vla-object BLK))
    
17.   (setq PINS (vlax-get BLKOBJ "insertionpoint"))
    
18.   (if (equal (cadr PINS)
    
19.              (cadr
    
20.                (car (acet-ent-geomextents ;|ACET-GEOM-EXTENTS|; BLK))
    
21.                                         ;LUCAS
    
22.              )
    
23.              0.001
    
24.       )
    
25.     (setq UP t)
    
26.   )
    

<br /> ;;沒有測試圖及使用說明!<br />   (arxload "acetutil.arx" NIL)                ;LUCAS<br />   (vl-cmdf "ucs" "w")                        ; "");LUCAS<br />   (setvar "osmode" 0)<br />   (vl-load-com)<br />   (setq BLK (entsel));選甚麼??帶屬性BLOCK??附圖較好!<br />   (setq PAT (cadr BLK))<br />   (setq BLK (car BLK))<br />   (if (null BLK)<br />     (progn (acet-ui-message "Block is not Selected" "SmartTool" 48)<br />            (quit)<br />     )<br />   )<br />   (setq BLKOBJ (vlax-ename->vla-object BLK))<br />   (setq PINS (vlax-get BLKOBJ "insertionpoint"))<br />   (if (equal (cadr PINS)<br />              (cadr<br />                (car (acet-ent-geomextents ;|ACET-GEOM-EXTENTS|; BLK))<br />                                         ;LUCAS<br />              )<br />              0.001<br />       )<br />     (setq UP t)<br />   )<br />

cancheung

期待这样的程序...最好是ARX的.

xoyo88

试验后，在发表