线条表格绘制

dcl1214 · 发表于 2024-12-28 18:48:00

本帖最后由 dcl1214 于 2024-12-28 18:58 编辑

客户现场人员5点都回家了，我一个人在这里写lisp（一会儿要给客户锁门），调试完毕了，现在分享出来

(defun $make-table-cad$ (jzs PT0 LST / $bg-heng$
$bg-shu$ $ents-move$ $text-box-ji-suan$
bg-n bg-t-p bg-t-p-y bj-h bj-s
clayer-old dq dxf dxfs
ents-all ents-l ents-t fonthigh fx-↑
hg h-old h-pj hs hxs
i i2 inspt jg jgs
kz obj-tc os-old p pts
qd r ro ss str
sty sxs tc t-e t-e-bt
t-h t-obj ts t-w w-old
ws x-ps xw-yhs ys
)
(defun $ents-move$ (ents pt lst / ORTHOMODE pt-n ss)
;带有捕捉版的图元移动
(if
(and ents (= (type ents) 'list) pt)
(progn
(setq ents (vl-remove-if-not
(function (lambda (a) (and a (entget a))))
ents
)
)
(setq ORTHOMODE (getvar 'ORTHOMODE))
(setvar 'ORTHOMODE 0)
(setq
pt-n
(vl-catch-all-apply
(function
(lambda (/ ss)
(setq ss (ssadd))
(last
(mapcar (function (lambda (x) (ssadd x ss))) ents)
)
(if ss
(progn
(VL-CMDF "MOVE" ss "" pt)
(while (= 1 (logand (getvar 'cmdactive) 1))
(vl-cmdf pause)
)
(getvar 'lastpoint)
)
)
)
)
)
)
(setvar 'ORTHOMODE ORTHOMODE)
(if (< (distance pt pt-n) 0.25)
(progn (mapcar 'entdel ents)
(repeat 5 (print "用户按下了esc,程序删除图元"))
)
)
)
)
pt-n
)
(DEFUN $text-box-ji-suan$
(jzs / a b i ro w-h w-hs xw-yhs $text-box-xw-yh$)
(defun $text-box-xw-yh$
(str T-H ro T-W sty bj-h bj-s / h tbox w)
;计算一个文字的X方向的W宽度，Y方向的H高度
(or (and ro (member (type ro) (list 'int 'real)))
(setq ro 0)
)
(AND T-W (SETQ T-W (* T-W 1.5)))
(if (and str T-H ro T-W sty)
(setq
tBox
(textbox (list
(cons 40 T-H)
(cons 1 str)
(cons 50 (* pi ro))
;旋转
(cons 41 T-W)
(cons 7 sty)
(cons 72 0)
;0左对齐，1居中
(cons 73 2)
)
)
)
)
(cond ((and ro
(/= ro 0) ;旋转了
(cadr tBox)
(car tBox)
(SETQ W (- (cadr (cadr tBox))
(cadr (car tBox))
)
)
;上面旋转了，所以这里用cadr
(SETQ h (abs (- (car (cadr tBox))
(car (car tBox))
)
)
;上面旋转了，这里用car
)
)
)
(t
(and (cadr tBox)
(car tBox)
(SETQ W (- (car (cadr tBox)) (car (car tBox))))
)
(and (cadr tBox)
(car tBox)
(SETQ h (- (cadr (cadr tBox)) (cadr (car tBox))))
)
)
)
(and bj-h w (setq w (+ w (* (abs bj-h) 2))))
(and bj-s h (setq h (+ h (* (abs bj-s) 2))))
(if (and w h)
(cons w h)
(cons 2.5 2.5)
)
)
(setq i 99)
(while (setq a (car jzs))
(setq w-hs nil)
(if (= i 0)
(setq ro (* pi 0.5))
(setq ro 0)
)
(setq ro 0)
(while (setq b (car a))
(setq w-h ($text-box-xw-yh$
b T-H ro T-W sty bj-h bj-s)
)
(setq w-hs (cons w-h w-hs))
(setq a (cdr a))
)
(setq w-hs (reverse w-hs))
(setq xw-yhs (cons w-hs xw-yhs))
;(setq i (1+ i))
(setq jzs (cdr jzs))
)
(setq xw-yhs (reverse xw-yhs))
)
(defun $BG-heng$
(p0 HS ws fx-↑ / a dxf DXFS
i jg jgs l-e p1 p1+0.5h p2
P-Y P-Z P-ZS w wzqdy y
)
;表格横线
(if (and HS ws)
(progn
(setq P-ZS nil)
(setq dxfs nil)
(setq jgs nil)
(setq w (apply '+ ws))
(setq dxfs nil)
(setq p1 p0)
(setq p2 (mapcar '+ p1 (list w 0 0))) ;右端坐标
(setq dxf (LIST '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
(setq L-e (vl-catch-all-apply 'entmakex (list dxf)))
(setq wzqdy (+ (CADR P1) (* (car hs) 0.5)))
(setq jg (list (cons "起点" p1)
(cons "止点" p2)
(cons "dxf" dxf)
(cons "图元" L-e)
(cons "文字起点Y" wzqdy)
;顶部第一行，不需要写文字
)
)
(setq jgs (cons jg jgs))
(SETQ i 0)
(while (setq a (car hs))
(if fx-↑
(setq p1 (mapcar '+ p1 (list 0 A 0))) ;上移一个高度
(setq p1 (mapcar '+ p1 (list 0 (- 0 a) 0))) ;下移一个行高
)
(setq p2 (mapcar '+ p1 (list w 0 0))) ;右端坐标
(setq dxf (LIST '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
(setq dxfs (cons dxf dxfs))
(setq L-e (vl-catch-all-apply 'entmakex (list dxf)))
(setq wzqdy (+ (CADR P1) (* A 0.5)))
(setq jg (list (cons "起点" p1)
(cons "止点" p2)
(cons "dxf" dxf)
(cons "图元" L-e)
(cons "文字起点Y" wzqdy)
)
)
(setq jgs (cons jg jgs))
(SETQ i (1+ i))
(setq hs (cdr hs))
)
(setq jgs (reverse jgs))
)
)
jgs
)
(DEFUN $BG-shu$
(P0 hs ws fx-↑ / a dxf dxfs h
i jg jgs l-e p1 p1+ p2 p-ss p-zs s-car
x-d xs x-u
)
;表格竖线
(if (and HS ws)
(progn
(setq P-ZS nil)
(setq dxfs nil)
(setq jgs nil)
(setq h (apply '+ hs))
(setq dxfs nil)
(setq p1 p0)
(IF fx-↑
(setq p2 (mapcar '+ p1 (list 0 H 0)))
(setq p2 (mapcar '+ p1 (list 0 (- 0 h) 0))) ;右端坐标
)
(setq dxf (LIST '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
(setq L-e (vl-catch-all-apply 'entmakex (list dxf)))
(setq jg (list (cons "起点" p1)
(cons "止点" p2)
(cons "dxf" dxf)
(cons "图元" L-e)
)
)
(setq jgs (cons jg jgs))
(SETQ i 99)
(while (setq a (car ws))
(IF (MEMBER i (list 0 1))
(progn
(setq p1 (mapcar '+ p1 (list a 0 0))) ;右移一个宽度
(setq
p1+ (mapcar '- p1 (list 0 (nth 0 hs) 0))
)
;右移一个宽度
(setq p2 (mapcar '- p1 (list 0 h 0))) ;下端坐标
(setq dxf (LIST '(0 . "LINE") (cons 10 p1+) (cons 11 p2)))
)
(progn
(setq p1 (mapcar '+ p1 (list a 0 0))) ;右移一个宽度
(IF fx-↑
(setq p2 (mapcar '+ p1 (list 0 H 0)))
(setq p2 (mapcar '+ p1 (list 0 (- 0 h) 0))) ;下端坐标
)
(setq dxf (LIST '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
)
)
(setq L-e (vl-catch-all-apply 'entmakex (list dxf)))
(setq jg (list (cons "起点" p1)
(cons "止点" p2)
(cons "dxf" dxf)
(cons "图元" L-e)
(cons "文字起点X" (- (CAR P1) (* A 0.5)))
)
)
(setq jgs (cons jg jgs))
;(SETQ i (1+ i))
(setq ws (cdr ws))
)
(setq jgs (reverse jgs))
)
)
jgs
)
(setq hg (CDR (ASSOC "行高" lst)))
(if (and hg (member (type bj-s) (list 'int 'real)))
()
(setq hg nil)
)
(setq bj-s (CDR (ASSOC "竖向边距" lst))) ;边距（竖向）
(or (and bj-s (member (type bj-s) (list 'int 'real)))
(setq bj-s 1.25)
)
(setq bj-h (CDR (ASSOC "横向边距" lst))) ;边距（横向）
(or (and bj-h (member (type bj-h) (list 'int 'real)))
(setq bj-h 1.25)
)
(if hg
(progn (setq bj-s 0) (setq bj-h 0))
)
(setq T-H (CDR (ASSOC "字体高度" lst)))
(or (and T-H (member (type T-H) (list 'int 'real)))
(setq T-H 2.5)
)
(or FontHigh (setq FontHigh (getvar 'textsize)))
(setq T-W (CDR (ASSOC "字体宽度" lst)))
(or T-W (setq T-W 0.7))
(setq insPt (CDR (ASSOC "坐标" LST)))
(setq tc (CDR (ASSOC "图层" lst)))
(setq ys (CDR (ASSOC "颜色" lst)))
(setq bg-n (CDR (ASSOC "标题" lst)))
(setq fx-↑ (= (CDR (ASSOC "方向" lst)) "↑"))
(or (and YS (member (type YS) (list 'int 'real)))
(setq YS 3)
)
(setq clayer-old (getvar "clayer"))
(SETQ OBJ-TC (vl-catch-all-apply
'vla-add
(list (vla-get-Layers
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
tc
)
)
)
(vl-catch-all-apply 'VLA-PUT-COLOR (LIST OBJ-TC YS))
(vl-catch-all-apply 'regapp (list "行列")) ;注册扩展名
(vl-catch-all-apply 'regapp (list "标题")) ;注册扩展名
(vl-catch-all-apply 'regapp (list "表格名")) ;注册扩展名
(setq sty (getvar 'textstyle))
(setq t-obj (vl-catch-all-apply
'vla-item
(list (vla-get-textstyles
(vla-get-activedocument
(vlax-get-acad-object)
)
)
sty
)
)
)
(setq h-old (VLA-get-Height t-obj))
(setq w-old (VLA-get-width t-obj))
(vl-catch-all-apply 'VLA-PUT-Height (list t-obj 0)) ;高度
(vl-catch-all-apply 'VLA-PUT-width (list t-obj 1)) ;宽度
(SETQ OS-OLD (GETVAR 'OSMODE))
(SETVAR 'OSMODE 0)
(vl-catch-all-apply
(function
(lambda (/)
(SETQ jzs
(MAPCAR
(FUNCTION
(LAMBDA (A)
(MAPCAR
(FUNCTION
(LAMBDA (B)
(if
(member b
(list " " " " " " " " " " " ")
)
(setq b "")
)
(IF (= (TYPE B) 'STR)
()
(SETQ B (VL-PRIN1-TO-STRING B))
)
B
)
)
a
)
)
)
jzs
)
) ;矫正字串，防止有非字串的数据
(setq xw-yhs nil)
(setq xw-yhs ($text-box-ji-suan$ jzs))
(SETQ HS
(MAPCAR (FUNCTION (LAMBDA (A) (APPLY 'MAX (MAPCAR 'CDR A))))
xw-yhs
)
) ;所有Y轴方向的高度
(setq ws
(MAPCAR (FUNCTION (LAMBDA (A) (APPLY 'MAX (MAPCAR 'CaR A))))
(apply 'mapcar (cons 'list xw-yhs)) ;转置
)
) ;所有的X轴方向的宽度
(setq h-PJ (/ (apply '+ hs) (length hs) 1.0))
;后面的所有行高除以行数，得到平均行高
(COND
((AND hg (MEMBER (TYPE HG) (LIST 'INT 'REAL)) (>= HG h-PJ))
(setq hs (mapcar (function (lambda (a) hg)) hs))
;传递进来的行高
)
(T
(setq hs (mapcar (function (lambda (a) h-PJ)) hs))
;平均行高
)
)
(setq ss nil)
(vl-catch-all-apply
(FUNCTION (LAMBDA () (SETVAR 'CLAYER tc)))
;图层置为当前
)
(setq hxs ($BG-heng$ PT0 HS ws fx-↑)) ;横向线条
(setq Sxs ($BG-shu$ PT0 HS ws fx-↑)) ;竖向线条
(and sxs (setq qd (cdr (assoc "起点" (cadddr sxs)))))
(SETQ
PTS (mapcar
(function
(lambda (A / y)
(SETQ Y (cdr (assoc "文字起点Y" A)))
(MAPCAR
(FUNCTION (LAMBDA (B / X)
(SETQ X (cdr (assoc "文字起点X" B)))
(LIST X Y 0)
)
)
(CDR SXS)
)
)
)
(IF fx-↑
hxs
(CDR hxs)
)
)
)
(PRINC)
(VL-CATCH-ALL-APPLY 'setvar (LIST "CLAYER" tc))
;图层置顶
(if fx-↑
(setq BG-T-P-y (cdr (assoc "文字起点Y" (last hxs))))
(setq BG-T-P-y (cdr (assoc "文字起点Y" (car hxs))))
)
(SETQ TS NIL)
(setq dxfs nil)
(setq jgs nil)
(setq i 0)
(while (and (setq r (car jzs)) (setq X-PS (car PTS)))
(setq i2 0)
(while (and (setq str (car r)) (setq p (car X-PS)))
(setq dxf nil)
(setq ro 0)
(setq dq 1)
(if (and str (/= str "") p (CAR P) (CADR P))
(progn (setq kz (list -3
(list "行列"
(cons 1000 (ITOA I))
(cons 1000 (ITOA I2))
)
(if bg-n
(LIST "表格名" (CONS 1000 bg-n))
)
)
)
(setq kz (vl-remove nil kz))
(setq dxf (LIST (cons 0 "TEXT")
(CONS 10 p)
(CONS 11 p)
(cons 40 T-H)
(CONS 1 STR)
(cons 50 ro)
(cons 41 T-W)
;(CONS 7 sty)
(cons 72 dq) ;0左对齐，1居中
(cons 73 2)
kz
)
)
(setq dxf (vl-remove nil dxf))
)
)
(if dxf
(progn
(setq T-E nil)
(SETQ T-E (vl-catch-all-apply 'entmakex (list DXF)))
(if (vl-catch-all-error-p T-E)
(setq T-E nil)
)
(setq jg (list (cons "行号" i)
(cons "列号" i2)
(cons "字串" str)
(cons "坐标" p)
(cons "图元" T-E)
(cons "dxf" dxf)
)
)
(if T-E
(setq ents-t (cons t-e ents-t))
)
(setq jgs (cons jg jgs))
)
)
(setq i2 (1+ i2))
(setq r (cdr r))
(setq X-PS (cdr X-PS))
)
(setq i (1+ i))
(setq jzs (cdr jzs))
(setq PTS (cdr PTS))
)
(setq jgs (reverse jgs))
(if bg-n
(progn
(SETQ BG-T-P (LIST (CAR pt0) (+ BG-T-P-y (* T-H 2)) 0))
(setq dxf (LIST (cons 0 "TEXT")
(CONS 10 BG-T-P)
(CONS 11 BG-T-P)
(cons 40 (* T-H 3))
(CONS 1 bg-n)
(cons 50 ro)
(cons 41 1.0)
;(CONS 7 sty)
(cons 72 0) ;0左对齐，1居中
(cons 73 2)
(list -3
(list "标题"
(cons 1000 bg-n)
)
)
)
)
(SETQ T-E-BT (vl-catch-all-apply 'entmakex (list DXF)))
(SETQ ENTS-T (CONS T-E-BT ENTS-T))
)
)
(PRINC)
(setq ents-L (mapcar (function (lambda (a)
(cdr (assoc "图元" a))
)
)
(vl-remove nil (append hxs sxs))
)
)
(setq ents-all (vl-remove nil (append ents-t ents-L)))
(IF (= (cdr (assoc "动态" lst)) "是")
(progn
(vl-catch-all-apply
(function (lambda ()
($ents-move$
ents-all
(cdr (assoc "起点" (car hxs)))
nil
)
)
)
)
)
)
)
)
)
(and OS-OLD (SETVAR 'OSMODE OS-OLD)) ;恢复捕捉
(and clayer-old (setvar 'clayer clayer-old)) ;恢复图层
(vl-catch-all-apply 'VLA-PUT-Height (list t-obj h-old)) ;高度
(vl-catch-all-apply 'VLA-PUT-width (list t-obj w-old)) ;宽度
ents-all
)
)

(defun $make-table-cad$        (jzs          PT0           LST            /             $bg-heng$ 
                         $bg-shu$ $ents-move$            $text-box-ji-suan$ 
                         bg-n          bg-t-p   bg-t-p-y bj-h     bj-s 
                         clayer-old           dq            dxf             dxfs 
                         ents-all ents-l   ents-t   fonthigh fx-↑ 
                         hg          h-old           h-pj            hs             hxs 
                         i          i2           inspt    jg             jgs 
                         kz          obj-tc   os-old   p             pts 
                         qd          r           ro            ss             str 
                         sty          sxs           tc            t-e             t-e-bt 
                         t-h          t-obj           ts            t-w             w-old 
                         ws          x-ps           xw-yhs   ys 
                        ) 
  (defun $ents-move$ (ents pt lst / ORTHOMODE pt-n ss) 
                                        ;带有捕捉版的图元移动 
    (if 
      (and ents (= (type ents) 'list) pt) 
       (progn 
         (setq ents (vl-remove-if-not 
                      (function (lambda (a) (and a (entget a)))) 
                      ents 
                    ) 
         ) 
         (setq ORTHOMODE (getvar 'ORTHOMODE)) 
         (setvar 'ORTHOMODE 0) 
         (setq 
           pt-n 
            (vl-catch-all-apply 
              (function 
                (lambda        (/ ss) 
                  (setq ss (ssadd)) 
                  (last 
                    (mapcar (function (lambda (x) (ssadd x ss))) ents) 
                  ) 
                  (if ss 
                    (progn 
                      (VL-CMDF "MOVE" ss "" pt) 
                      (while (= 1 (logand (getvar 'cmdactive) 1)) 
                        (vl-cmdf pause) 
                      ) 
                      (getvar 'lastpoint) 
                    ) 
                  ) 
                ) 
              ) 
            ) 
         ) 
         (setvar 'ORTHOMODE ORTHOMODE) 
         (if (< (distance pt pt-n) 0.25) 
           (progn (mapcar 'entdel ents) 
                  (repeat 5 (print "用户按下了esc,程序删除图元")) 
           ) 
         ) 
       ) 
    ) 
    pt-n 
  ) 
  (DEFUN $text-box-ji-suan$ 
         (jzs / a b i ro w-h w-hs xw-yhs $text-box-xw-yh$) 
    (defun $text-box-xw-yh$ 
                            (str T-H ro T-W sty bj-h bj-s / h tbox w) 
                                        ;计算一个文字的X方向的W宽度，Y方向的H高度 
      (or (and ro (member (type ro) (list 'int 'real))) 
          (setq ro 0) 
      ) 
      (AND T-W (SETQ T-W (* T-W 1.5))) 
      (if (and str T-H ro T-W sty) 
        (setq 
          tBox 
           (textbox (list 
                      (cons 40 T-H) 
                      (cons 1 str) 
                      (cons 50 (* pi ro)) 
                                        ;旋转 
                      (cons 41 T-W) 
                      (cons 7 sty) 
                      (cons 72 0) 
                                        ;0左对齐，1居中 
                      (cons 73 2) 
                    ) 
           ) 
        ) 
      ) 
      (cond ((and ro 
                  (/= ro 0)                ;旋转了 
                  (cadr tBox) 
                  (car tBox) 
                  (SETQ        W (- (cadr (cadr tBox)) 
                             (cadr (car tBox)) 
                          ) 
                  ) 
                                        ;上面旋转了，所以这里用cadr 
                  (SETQ        h (abs (- (car (cadr tBox)) 
                                  (car (car tBox)) 
                               ) 
                          ) 
                                        ;上面旋转了，这里用car 
                  ) 
             ) 
            ) 
            (t 
             (and (cadr tBox) 
                  (car tBox) 
                  (SETQ W (- (car (cadr tBox)) (car (car tBox)))) 
             ) 
             (and (cadr tBox) 
                  (car tBox) 
                  (SETQ h (- (cadr (cadr tBox)) (cadr (car tBox)))) 
             ) 
            ) 
      ) 
      (and bj-h w (setq w (+ w (* (abs bj-h) 2)))) 
      (and bj-s h (setq h (+ h (* (abs bj-s) 2)))) 
      (if (and w h) 
        (cons w h) 
        (cons 2.5 2.5) 
      ) 
    ) 
    (setq i 99) 
    (while (setq a (car jzs)) 
      (setq w-hs nil) 
      (if (= i 0) 
        (setq ro (* pi 0.5)) 
        (setq ro 0) 
      ) 
      (setq ro 0) 
      (while (setq b (car a)) 
        (setq w-h ($text-box-xw-yh$ 
                    b T-H ro T-W sty bj-h bj-s) 
        ) 
        (setq w-hs (cons w-h w-hs)) 
        (setq a (cdr a)) 
      ) 
      (setq w-hs (reverse w-hs)) 
      (setq xw-yhs (cons w-hs xw-yhs)) 
                                        ;(setq i (1+ i)) 
      (setq jzs (cdr jzs)) 
    ) 
    (setq xw-yhs (reverse xw-yhs)) 
  ) 
 
  (defun $BG-heng$ 
                   (p0          HS        ws    fx-↑ /          a        dxf   DXFS 
                    i          jg        jgs   l-e   p1          p1+0.5h     p2 
                    P-Y          P-Z        P-ZS  w            wzqdy y 
                   ) 
                                        ;表格横线 
    (if        (and HS ws) 
      (progn 
        (setq P-ZS nil) 
        (setq dxfs nil) 
        (setq jgs nil) 
        (setq w (apply '+ ws)) 
        (setq dxfs nil) 
        (setq p1 p0) 
        (setq p2 (mapcar '+ p1 (list w 0 0))) ;右端坐标 
        (setq dxf (LIST '(0 . "LINE") (cons 10 p1) (cons 11 p2))) 
        (setq L-e (vl-catch-all-apply 'entmakex (list dxf))) 
        (setq wzqdy (+ (CADR P1) (* (car hs) 0.5))) 
        (setq jg (list (cons "起点" p1) 
                       (cons "止点" p2) 
                       (cons "dxf" dxf) 
                       (cons "图元" L-e) 
                       (cons "文字起点Y" wzqdy) 
                                        ;顶部第一行，不需要写文字 
                 ) 
        ) 
        (setq jgs (cons jg jgs)) 
        (SETQ i 0) 
        (while (setq a (car hs)) 
          (if fx-↑ 
            (setq p1 (mapcar '+ p1 (list 0 A 0))) ;上移一个高度 
            (setq p1 (mapcar '+ p1 (list 0 (- 0 a) 0))) ;下移一个行高 
          ) 
          (setq p2 (mapcar '+ p1 (list w 0 0))) ;右端坐标 
          (setq dxf (LIST '(0 . "LINE") (cons 10 p1) (cons 11 p2))) 
          (setq dxfs (cons dxf dxfs)) 
          (setq L-e (vl-catch-all-apply 'entmakex (list dxf))) 
          (setq wzqdy (+ (CADR P1) (* A 0.5))) 
          (setq        jg (list (cons "起点" p1) 
                         (cons "止点" p2) 
                         (cons "dxf" dxf) 
                         (cons "图元" L-e) 
                         (cons "文字起点Y" wzqdy) 
                   ) 
          ) 
          (setq jgs (cons jg jgs)) 
          (SETQ i (1+ i)) 
          (setq hs (cdr hs)) 
        ) 
        (setq jgs (reverse jgs)) 
      ) 
    ) 
    jgs 
  ) 
 
  (DEFUN $BG-shu$ 
                  (P0        hs   ws          fx-↑            /         a    dxf  dxfs        h 
                   i        jg   jgs  l-e  p1   p1+         p2   p-ss p-zs        s-car 
                   x-d        xs   x-u 
                  ) 
                                        ;表格竖线 
    (if        (and HS ws) 
      (progn 
        (setq P-ZS nil) 
        (setq dxfs nil) 
        (setq jgs nil) 
        (setq h (apply '+ hs)) 
        (setq dxfs nil) 
        (setq p1 p0) 
        (IF fx-↑ 
          (setq p2 (mapcar '+ p1 (list 0 H 0))) 
          (setq p2 (mapcar '+ p1 (list 0 (- 0 h) 0))) ;右端坐标 
        ) 
        (setq dxf (LIST '(0 . "LINE") (cons 10 p1) (cons 11 p2))) 
        (setq L-e (vl-catch-all-apply 'entmakex (list dxf))) 
        (setq jg (list (cons "起点" p1) 
                       (cons "止点" p2) 
                       (cons "dxf" dxf) 
                       (cons "图元" L-e) 
                 ) 
        ) 
        (setq jgs (cons jg jgs)) 
        (SETQ i 99) 
        (while (setq a (car ws)) 
          (IF (MEMBER i (list 0 1)) 
            (progn 
              (setq p1 (mapcar '+ p1 (list a 0 0))) ;右移一个宽度 
              (setq 
                p1+ (mapcar '- p1 (list 0 (nth 0 hs) 0)) 
              ) 
                                        ;右移一个宽度 
              (setq p2 (mapcar '- p1 (list 0 h 0))) ;下端坐标 
              (setq dxf (LIST '(0 . "LINE") (cons 10 p1+) (cons 11 p2))) 
            ) 
            (progn 
              (setq p1 (mapcar '+ p1 (list a 0 0))) ;右移一个宽度 
              (IF fx-↑ 
                (setq p2 (mapcar '+ p1 (list 0 H 0))) 
                (setq p2 (mapcar '+ p1 (list 0 (- 0 h) 0))) ;下端坐标 
              ) 
              (setq dxf (LIST '(0 . "LINE") (cons 10 p1) (cons 11 p2))) 
            ) 
          ) 
          (setq L-e (vl-catch-all-apply 'entmakex (list dxf))) 
          (setq        jg (list (cons "起点" p1) 
                         (cons "止点" p2) 
                         (cons "dxf" dxf) 
                         (cons "图元" L-e) 
                         (cons "文字起点X" (- (CAR P1) (* A 0.5))) 
                   ) 
          ) 
          (setq jgs (cons jg jgs)) 
                                        ;(SETQ i (1+ i)) 
          (setq ws (cdr ws)) 
        ) 
        (setq jgs (reverse jgs)) 
      ) 
    ) 
    jgs 
  ) 
  (setq hg (CDR (ASSOC "行高" lst))) 
  (if (and hg (member (type bj-s) (list 'int 'real))) 
    () 
    (setq hg nil) 
  ) 
  (setq bj-s (CDR (ASSOC "竖向边距" lst))) ;边距（竖向）          
  (or (and bj-s (member (type bj-s) (list 'int 'real))) 
      (setq bj-s 1.25) 
  ) 
  (setq bj-h (CDR (ASSOC "横向边距" lst))) ;边距（横向） 
  (or (and bj-h (member (type bj-h) (list 'int 'real))) 
      (setq bj-h 1.25) 
  ) 
  (if hg 
    (progn (setq bj-s 0) (setq bj-h 0)) 
  ) 
  (setq T-H (CDR (ASSOC "字体高度" lst))) 
  (or (and T-H (member (type T-H) (list 'int 'real))) 
      (setq T-H 2.5) 
  ) 
  (or FontHigh (setq FontHigh (getvar 'textsize))) 
  (setq T-W (CDR (ASSOC "字体宽度" lst))) 
  (or T-W (setq T-W 0.7)) 
  (setq insPt (CDR (ASSOC "坐标" LST))) 
  (setq tc (CDR (ASSOC "图层" lst))) 
  (setq ys (CDR (ASSOC "颜色" lst))) 
  (setq bg-n (CDR (ASSOC "标题" lst))) 
  (setq fx-↑ (= (CDR (ASSOC "方向" lst)) "↑")) 
  (or (and YS (member (type YS) (list 'int 'real))) 
      (setq YS 3) 
  ) 
  (setq clayer-old (getvar "clayer")) 
 
  (SETQ        OBJ-TC (vl-catch-all-apply 
                 'vla-add 
                 (list (vla-get-Layers 
                         (vla-get-ActiveDocument 
                           (vlax-get-acad-object) 
                         ) 
                       ) 
                       tc 
                 ) 
               ) 
  ) 
  (vl-catch-all-apply 'VLA-PUT-COLOR (LIST OBJ-TC YS)) 
  (vl-catch-all-apply 'regapp (list "行列")) ;注册扩展名 
  (vl-catch-all-apply 'regapp (list "标题")) ;注册扩展名 
  (vl-catch-all-apply 'regapp (list "表格名")) ;注册扩展名 
  (setq sty (getvar 'textstyle)) 
  (setq        t-obj (vl-catch-all-apply 
                'vla-item 
                (list (vla-get-textstyles 
                        (vla-get-activedocument 
                          (vlax-get-acad-object) 
                        ) 
                      ) 
                      sty 
                ) 
              ) 
  ) 
  (setq h-old (VLA-get-Height t-obj)) 
  (setq w-old (VLA-get-width t-obj)) 
  (vl-catch-all-apply 'VLA-PUT-Height (list t-obj 0)) ;高度 
  (vl-catch-all-apply 'VLA-PUT-width (list t-obj 1)) ;宽度   
  (SETQ OS-OLD (GETVAR 'OSMODE)) 
  (SETVAR 'OSMODE 0) 
  (vl-catch-all-apply 
    (function 
      (lambda (/) 
        (SETQ jzs 
               (MAPCAR 
                 (FUNCTION 
                   (LAMBDA (A) 
                     (MAPCAR 
                       (FUNCTION 
                         (LAMBDA (B) 
                           (if 
                             (member b 
                                     (list " " "  " "   " "    " "     " "        ") 
                             ) 
                              (setq b "") 
                           ) 
                           (IF (= (TYPE B) 'STR) 
                             () 
                             (SETQ B (VL-PRIN1-TO-STRING B)) 
                           ) 
                           B 
                         ) 
                       ) 
                       a 
                     ) 
                   ) 
                 ) 
                 jzs 
               ) 
        )                                ;矫正字串，防止有非字串的数据 
 
        (setq xw-yhs nil) 
        (setq xw-yhs ($text-box-ji-suan$ jzs)) 
        (SETQ HS 
               (MAPCAR (FUNCTION (LAMBDA (A) (APPLY 'MAX (MAPCAR 'CDR A)))) 
                       xw-yhs 
               ) 
        )                                ;所有Y轴方向的高度 
 
        (setq ws 
               (MAPCAR (FUNCTION (LAMBDA (A) (APPLY 'MAX (MAPCAR 'CaR A)))) 
                       (apply 'mapcar (cons 'list xw-yhs)) ;转置 
               ) 
        )                                ;所有的X轴方向的宽度 
        (setq h-PJ (/ (apply '+ hs) (length hs) 1.0)) 
                                        ;后面的所有行高除以行数，得到平均行高 
        (COND 
          ((AND hg (MEMBER (TYPE HG) (LIST 'INT 'REAL)) (>= HG h-PJ)) 
           (setq hs (mapcar (function (lambda (a) hg)) hs)) 
                                        ;传递进来的行高 
          ) 
          (T 
           (setq hs (mapcar (function (lambda (a) h-PJ)) hs)) 
                                        ;平均行高 
          ) 
        ) 
        (setq ss nil) 
        (vl-catch-all-apply 
          (FUNCTION (LAMBDA () (SETVAR 'CLAYER tc))) 
                                        ;图层置为当前 
        ) 
        (setq hxs ($BG-heng$ PT0 HS ws fx-↑)) ;横向线条 
        (setq Sxs ($BG-shu$ PT0 HS ws fx-↑)) ;竖向线条 
        (and sxs (setq qd (cdr (assoc "起点" (cadddr sxs))))) 
        (SETQ 
          PTS (mapcar 
                (function 
                  (lambda (A / y) 
                    (SETQ Y (cdr (assoc "文字起点Y" A))) 
                    (MAPCAR 
                      (FUNCTION        (LAMBDA        (B / X) 
                                  (SETQ X (cdr (assoc "文字起点X" B))) 
                                  (LIST X Y 0) 
                                ) 
                      ) 
                      (CDR SXS) 
                    ) 
                  ) 
                ) 
                (IF fx-↑ 
                  hxs 
                  (CDR hxs) 
                ) 
              ) 
        ) 
        (PRINC) 
        (VL-CATCH-ALL-APPLY 'setvar (LIST "CLAYER" tc)) 
                                        ;图层置顶 
        (if fx-↑ 
          (setq BG-T-P-y (cdr (assoc "文字起点Y" (last hxs)))) 
          (setq BG-T-P-y (cdr (assoc "文字起点Y" (car hxs)))) 
        ) 
        (SETQ TS NIL) 
        (setq dxfs nil) 
        (setq jgs nil) 
        (setq i 0) 
        (while (and (setq r (car jzs)) (setq X-PS (car PTS))) 
          (setq i2 0) 
          (while (and (setq str (car r)) (setq p (car X-PS))) 
            (setq dxf nil) 
            (setq ro 0) 
            (setq dq 1) 
            (if        (and str (/= str "") p (CAR P) (CADR P)) 
              (progn (setq kz (list -3 
                                    (list "行列" 
                                          (cons 1000 (ITOA I)) 
                                          (cons 1000 (ITOA I2)) 
                                    ) 
                                    (if        bg-n 
                                      (LIST "表格名" (CONS 1000 bg-n)) 
                                    ) 
                              ) 
                     ) 
                     (setq kz (vl-remove nil kz)) 
                     (setq dxf (LIST (cons 0 "TEXT") 
                                     (CONS 10 p) 
                                     (CONS 11 p) 
                                     (cons 40 T-H) 
                                     (CONS 1 STR) 
                                     (cons 50 ro) 
                                     (cons 41 T-W) 
                                        ;(CONS 7 sty) 
                                     (cons 72 dq) ;0左对齐，1居中 
                                     (cons 73 2) 
                                     kz 
                               ) 
                     ) 
                     (setq dxf (vl-remove nil dxf)) 
              ) 
            ) 
            (if        dxf 
              (progn 
                (setq T-E nil) 
                (SETQ T-E (vl-catch-all-apply 'entmakex (list DXF))) 
                (if (vl-catch-all-error-p T-E) 
                  (setq T-E nil) 
                ) 
                (setq jg (list (cons "行号" i) 
                               (cons "列号" i2) 
                               (cons "字串" str) 
                               (cons "坐标" p) 
                               (cons "图元" T-E) 
                               (cons "dxf" dxf) 
                         ) 
                ) 
                (if T-E 
                  (setq ents-t (cons t-e ents-t)) 
                ) 
                (setq jgs (cons jg jgs)) 
              ) 
            ) 
            (setq i2 (1+ i2)) 
            (setq r (cdr r)) 
            (setq X-PS (cdr X-PS)) 
          ) 
          (setq i (1+ i)) 
          (setq jzs (cdr jzs)) 
          (setq PTS (cdr PTS)) 
        ) 
        (setq jgs (reverse jgs)) 
        (if bg-n 
          (progn 
            (SETQ BG-T-P (LIST (CAR pt0) (+ BG-T-P-y (* T-H 2)) 0)) 
            (setq dxf (LIST (cons 0 "TEXT") 
                            (CONS 10 BG-T-P) 
                            (CONS 11 BG-T-P) 
                            (cons 40 (* T-H 3)) 
                            (CONS 1 bg-n) 
                            (cons 50 ro) 
                            (cons 41 1.0) 
                                        ;(CONS 7 sty) 
                            (cons 72 0)        ;0左对齐，1居中 
                            (cons 73 2) 
                            (list -3 
                                  (list        "标题" 
                                        (cons 1000 bg-n) 
                                  ) 
                            ) 
                      ) 
            ) 
            (SETQ T-E-BT (vl-catch-all-apply 'entmakex (list DXF))) 
            (SETQ ENTS-T (CONS T-E-BT ENTS-T)) 
          ) 
        ) 
        (PRINC) 
        (setq ents-L (mapcar (function (lambda (a) 
                                         (cdr (assoc "图元" a)) 
                                       ) 
                             ) 
                             (vl-remove nil (append hxs sxs)) 
                     ) 
        ) 
        (setq ents-all (vl-remove nil (append ents-t ents-L))) 
        (IF (= (cdr (assoc "动态" lst)) "是") 
          (progn 
            (vl-catch-all-apply 
              (function        (lambda        () 
                          ($ents-move$ 
                            ents-all 
                            (cdr (assoc "起点" (car hxs))) 
                            nil 
                          ) 
                        ) 
              ) 
            ) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (and OS-OLD (SETVAR 'OSMODE OS-OLD))        ;恢复捕捉 
  (and clayer-old (setvar 'clayer clayer-old)) ;恢复图层 
  (vl-catch-all-apply 'VLA-PUT-Height (list t-obj h-old)) ;高度 
  (vl-catch-all-apply 'VLA-PUT-width (list t-obj w-old)) ;宽度   
  ents-all 
) 
)

;调用方法如下：

($make-table-cad$
(list
(list "线束零件号" "选项配置" "功能代号"
"ETC" "感应雨刮" "全景天窗"
"行车记录仪USB口" "蓝牙" "语音识别"
"T-BOX" "自动防炫目内后视镜"
"高位制动灯-LED" "中顶灯" "无拉手"
)
(list "序号" "线束零件号" "代号" "ET01"
"WB01" "RA02" "IH04" "ID04" "ID02"
"ID01" "ME01" "SL10" "LF08" "NAU00"
)
(list "1" "4002100APW13A" "V1" "X" "" ""
"" "X" "" "" "" "X" ""
""
)
(list "2" "4002101APW13A" "V2" "X" "" ""
"" "X" "" "" "" "" ""
""
)
(list "3" "4002102APW13A" "V3" "X" "X" "X"
"X" "" "X" "X" "X" "X" ""
""
)
(list "4" "4002103APW13A" "V4" "X" "X" "X"
"X" "" "X" "" "" "X" ""
""
)
(list "5" "4002104APW13A" "V5" "" "" ""
"" "X" "" "" "X" "" ""
""
)
(list "6" "4002104APW13A" "V6" "" "" ""
"" "X" "" "" "" "" ""
""
)
(list "7" "" "" "" "" "" "" "" "" "" "" "" "" "")
(list "8" "4002104APW13A" "V7" "" "X" "X"
"X" "" "X" "X" "X" "X" ""
""
)
)
(getpoint "请点击鼠标左键开始绘制表格")
(list
(CONS "标题" "选项配置表")
(cons "行高" 0)
(cons "图层" "小白兔")
(cons "颜色" 3)
(cons "竖向边距" 1)
(cons "横向边距" 0)
(CONS "字体高度" 3)
(CONS "字体宽度" 0.65)
(CONS "动态" "否")
(CONS "方向" "↓")
)
)

($make-table-cad$ 
  (list 
    (list "线束零件号"      "选项配置"        "功能代号" 
    "ETC"        "感应雨刮"        "全景天窗" 
    "行车记录仪USB口" "蓝牙"        "语音识别" 
    "T-BOX"      "自动防炫目内后视镜" 
    "高位制动灯-LED"  "中顶灯"        "无拉手" 
   ) 
    (list "序号"     "线束零件号"     "代号"     "ET01" 
    "WB01"     "RA02"  "IH04"     "ID04"     "ID02" 
    "ID01"     "ME01"  "SL10"     "LF08"     "NAU00" 
   ) 
    (list "1"    "4002100APW13A" "V1"    "X"    ""    "" 
    ""    "X"    ""    ""    ""    "X"    "" 
    "" 
   ) 
    (list "2"    "4002101APW13A" "V2"    "X"    ""    "" 
    ""    "X"    ""    ""    ""    ""    "" 
    "" 
   ) 
    (list "3"    "4002102APW13A" "V3"    "X"    "X"    "X" 
    "X"    ""    "X"    "X"    "X"    "X"    "" 
    "" 
   ) 
    (list "4"    "4002103APW13A" "V4"    "X"    "X"    "X" 
    "X"    ""    "X"    ""    ""    "X"    "" 
    "" 
   ) 
    (list "5"    "4002104APW13A" "V5"    ""    ""    "" 
    ""    "X"    ""    ""    "X"    ""    "" 
    "" 
   ) 
    (list "6"    "4002104APW13A" "V6"    ""    ""    "" 
    ""    "X"    ""    ""    ""    ""    "" 
    "" 
   ) 
    (list "7" "" "" "" "" "" ""  "" "" "" "" "" "" "") 
    (list "8"    "4002104APW13A" "V7"    ""    "X"    "X" 
    "X"    ""    "X"    "X"    "X"    "X"    "" 
    "" 
   ) 
 
  ) 
  (getpoint "请点击鼠标左键开始绘制表格") 
  (list 
    (CONS "标题" "选项配置表") 
    (cons "行高" 0) 
    (cons "图层" "小白兔") 
    (cons "颜色" 3) 
    (cons "竖向边距" 1) 
    (cons "横向边距" 0) 
    (CONS "字体高度" 3) 
    (CONS "字体宽度" 0.65) 
    (CONS "动态" "否") 
    (CONS "方向" "↓") 
 
  ) 
 
)

煮茗 · 发表于 2024-12-28 19:23:01

帮忙贴图来了

lzspain · 发表于 2024-12-28 19:45:29

煮茗发表于 2024-12-28 19:23
帮忙贴图来了

部分列宽小了

煮茗 · 发表于 2024-12-28 19:52:08

lzspain 发表于 2024-12-28 19:45
部分列宽小了

应该是我这边字体的问题。
我测试是先生成的表格，发现有问号，调整了字体就出现溢出的情况。
如果先设置好字体再生成表格不会有这种情况。

tender138 · 发表于 2024-12-28 21:03:28

源码必须顶！！！

yk1216 · 发表于 2024-12-29 18:42:48

谢谢分享，膜拜~~~

e2002 · 发表于 2024-12-29 20:26:41

excel表格感觉更好些。

数据源头，如果是dwg中Insert对象（含有Attributes），可以联合 data extract ，datalink，table ，实现数据联动。

不过现在的 datalink还存在一些问题，希望开发组能尽快解决。

brucecad · 发表于 2024-12-31 19:49:27

煮茗发表于 2024-12-28 19:23
帮忙贴图来了

真是棒
一目了然
感謝你
感恩

puzb2023 · 发表于 2025-1-2 09:38:54

源码必须顶！

账号		自动登录	找回密码
密码			注册

[源码] 线条表格绘制

点评

评分

本帖子中包含更多资源