[LISP程序]：一个生成属性块表格的小工具

lsjjm

一个生成属性块表格的小工具
功能: 生成除标题外的文字为属性的二维块表格.
         自适应左右对齐,
         自适应标题上下位置.
         提示默认行间距,列宽
本程序是从公司工作程序摘录出来, 原始数据只供参考, 网友可从对话框输入或其他外部数据文件提取.
[PHP]
(defun c:test (/ wl hl)
  (setvar "osmode" 37)
  (setq h0 0.35 w0 1.0 th 0.08)
  (setq row (getint "\nNumber of Rows<3>:"))
  (if (or (null row)(= row ""))(setq row 3))
  (setq col (getint "\nNumber of Column<4>:"))
  (if (or (null col)(= col ""))(setq col 4))
  (setq  p0 (getpoint "\nPick Insert Point:"))
  (setq ss0 (ssget "x" '((0 . "*LINE,TEXT,ATTDEF"))))
  (setq n 1)
  (while (<= n row)
    (setq h (getdist (strcat "\nHeight of No" (itoa n) " Row<" (rtos h0 2 2) ">:")))
    (if (or (null h)(= h ""))(setq h h0))
    (setq hl (append hl (list h)))
    (setq h0 h)
    (setq n (1+ n))
  )
  (setq n 1)
  (while (<= n col)
    (setq w (getdist (strcat "\nWidth of No" (itoa n) " Column<" (rtos w0 2 2) ">:")))
    (if (or (null w )(= w ""))(setq w w0))
    (setq wl (append wl (list w)))
    (setq w0 w)
    (setq n (1+ n))
  )
  (setq p00 p0 m 1 ang (/ pi 4))
  (setq ee (ssget "f" (list (polar p0 pi 0.001)(polar p0 pi 0.002))))
  (if ee
    (setq p0 (polar p0 pi (apply '+ wl)))
    (setq ang (- ang))
  )
  (setq ff (ssget "f" (list (polar p00 (- (* 1.5 pi) ang) 0.001)
                (polar p00 (- (* 1.5 pi) ang) 1.0))))
  (if ff (setq m (- m)))
  (setvar "osmode" 0)
  (vl-cmdf "line" p0 (polar p0 0 (apply '+ wl)) "")
  (foreach i hl
    (vl-cmdf "copy" (entlast) "" p0 (polar p0 (* 1.5 pi)(* m i)) "")
  )
  (vl-cmdf "line" p0 (polar p0 (* 1.5 pi)(* m (apply '+ hl))) "")
  (foreach i wl
    (vl-cmdf "copy" (entlast) "" p0 (polar p0 0 i) "")
  )
  (setq n 0 p1 p0)
  (while (< n col)
    (setq txt (getstring (strcat "\nType in No" (itoa (1+ n)) " Column Head Text:")))
    (setq ipt (list (+ (car p1)(/ (nth n wl) 2))(- (cadr p1)(/ (car hl) 2 m))))
    (vl-cmdf "text" "j" "mc" ipt th 0 (strcase txt) "")
    (setq p1 (polar p1 0 (nth n wl)))
    (setq n (1+ n))
  )
  (setq ss (ssget "x" '((0 . "*LINE,TEXT,ATTDEF"))))
  (vl-cmdf "select" ss "r" ss0 "")
  (setq ss3 (ssget "p"))
  (setq A (rtos (* (getvar "CDATE") 1E8)))
  (vl-cmdf "block" A p0 ss3 "")
  (vl-cmdf "insert" A p0 "" "" "")
  (setq blk (entlast))
  (setq i 1 n 0 y (* m (car hl)))
  (setvar "cecolor" "6")
  (while (<= i row)
    (setq j 0 x 0)
    (setq y (+ y (/ (nth i hl) 2 m)))
    (while (< j col)
      (setq x (+ x (/ (nth j wl) 2)))
      (setq ipt (list (+ (car p0) x)(- (cadr p0) y)))
      (addatttoblock blk th "" ipt (strcat "T" (itoa n))
                                     (strcase (getstring (strcat "\n" (itoa i)"-" (itoa j) " Item String: "))))
      (setq blk (entlast))
      (setq x (+ x (/ (nth j wl) 2)))
      (setq n (1+ n))
      (setq j (1+ j))
    )
    (setq y (+ y (/ (nth i hl) 2 m)))
    (setq i (1+ i))
  )
)
;
(defun addatttoblock (blk h prom ptatt tag v)
  (setq doc (vla-get-activedocument (vlax-get-acad-object))
        obj (vlax-ename->vla-object blk)
      ptblk (vlax-safearray->list
              (vlax-variant-value (vla-get-insertionpoint obj)))
     blkdef (vla-item (vla-get-blocks doc)(vla-get-name obj))
      ptatt (vlax-3d-point (mapcar '- ptatt ptblk))  
       attdef (vla-addattribute blkdef h acAttributeModeverify prom ptatt tag v))
  (vla-put-alignment attdef 10)
  (vla-put-textalignmentpoint attdef ptatt)
  (if (= (getvar "tilemode") 1)
    (setq space (vla-get-modelspace doc))
    (setq space (vla-get-paperspace doc))
  )
  (setq blkref (vla-insertblock
                 space
                 (vlax-3d-point ptblk)
                 (vla-get-name blkdef)
                 (vla-get-xscalefactor obj)
                 (vla-get-yscalefactor obj)
                 (vla-get-zscalefactor obj)
                 (vla-get-rotation obj)
               )
  )
  (vla-delete obj)
  (vlax-release-object obj)
)
[/PHP]