有一段时间没来，献上俺最近做的一个动态画立面窗的lsp
;==========================================================立面;;-----------------------;
;画立面窗;
;-----------------------;
;模拟显示数字;
;-----------------------;
(defun feng:num:grvecs ( li / num n temp str po )
(setq num '(("1" (150 0 0) (150 300 0))
("2" (150 0 0) (0 0 0) (0 0 0) (0 150 0) (0 150 0) (150 150 0) (150 150 0) (150 300 0) (150 300 0) (0 300 0))
("3" (0 0 0) (150 0 0) (150 0 0) (150 150 0) (150 150 0) (0 150 0) (150 150 0) (150 300 0) (150 300 0) (0 300 0))
("4" (150 0 0) (150 150 0) (150 150 0) (150 300 0) (150 150 0) (0 150 0) (0 150 0) (0 300 0))
("5" (0 0 0) (150 0 0) (150 0 0) (150 150 0) (150 150 0) (0 150 0) (0 150 0) (0 300 0) (0 300 0) (150 300 0))
("6" (150 300 0) (0 300 0) (0 300 0) (0 0 0) (0 0 0) (150 0 0) (150 0 0) (150 150 0) (150 150 0) (0 150 0))
("7" (150 0 0) (150 300 0) (150 300 0) (0 300 0))
("8" (0 0 0) (150 0 0) (150 0 0) (150 300 0) (150 300 0) (0 300 0) (0 300 0) (0 0 0) (0 150 0) (150 150 0))
("9" (0 0 0) (150 0 0) (150 0 0) (150 300 0) (150 300 0) (0 300 0) (0 300 0) (0 150 0) (0 150 0) (150 150 0))
("0" (0 0 0) (150 0 0) (150 0 0) (150 300 0) (150 300 0) (0 300 0) (0 300 0) (0 0 0))
("." (60 0 0) (90 0 0) (90 0 0) (90 30 0) (90 30 0) (60 30 0) (60 30 0) (60 0 0))
("-" (0 150 0) (150 150 0))
)
po (last li)
li (car li)
str (substr (setq str (apply 'strcat (MAPCAR '(LAMBDA (x) (strcat x "-")) li))) 1 (1- (strlen str)))
n 0
)
(while (<= n (strlen str))
(setq temp (substr str (setq n (1+ n)) 1)
po (MAPCAR '+ po '(250 0 0))
)
(GRVECS (cons 1 (MAPCAR '(LAMBDA (x) (MAPCAR '+ x po)) (cdr (assoc temp num)))))
)
)
;-----------------------;
;画矩形框;
;-----------------------;
(defun feng:window:rec ( ms p1 / p2 gr l1 l2 temp1 temp2 li grvli tt )
(while (/= (car (setq gr (grread t 4 2))) 3)
(cond
((or (= (cadr gr) 84) (= (cadr gr) 116))
(if tt (setq tt nil) (setq tt t))
)
((= (car gr) 5)
(progn
(redraw)
(setq p2 (MAPCAR '(LAMBDA (x y) (+ x (* (fix (/ (- y x) (if tt 50 100))) (if tt 50.0 100.0)))) p1 (cadr gr))
l1 (if (null tt)
(feng:window:rec:temp (list (list (min (car p1) (car p2)) (min (cadr p1) (cadr p2)) 0)
(list (max (car p1) (car p2)) (max (cadr p1) (cadr p2)) 0)
)
)
(feng:window:rec:temp (list (list (min (- (* (car p1) 2) (car p2)) (car p2)) (min (cadr p1) (cadr p2)) 0)
(list (max (- (* (car p1) 2) (car p2)) (car p2)) (max (cadr p1) (cadr p2)) 0)
)
)
)
l2 (feng:window:rec:temp (MAPCAR '(LAMBDA (x y) (MAPCAR '+ x y)) (list (car l1) (caddr l1)) '((50 50 0) (-50 -50 0))))
temp (cdr (REVERSE (MAPCAR '(LAMBDA (x y) (abs (- y x))) (car l1) (caddr l1))))
)
(GRVECS (cons 1 (REVERSE (cons (car l1) (REVERSE (cdr (apply 'append (MAPCAR '(LAMBDA (x) (list x x)) l1))))))))
(GRVECS (cons 2 (REVERSE (cons (car l2) (REVERSE (cdr (apply 'append (MAPCAR '(LAMBDA (x) (list x x)) l2))))))))
(feng:num:grvecs (list (REVERSE (cons (rtos (/ (apply '* temp) 1000000) 2 2) (MAPCAR '(LAMBDA (z) (rtos z 2 0)) temp))) (cadr gr)))
)
)
)
)
(redraw)
(list (list (feng:window:addobject ms l1) (feng:window:addobject ms l2)) (list l1 l2))
)
(defun feng:window:rec:temp ( li / p1 p2 )
(list (setq p1 (car li))
(list (car (setq p2 (cadr li))) (cadr p1) 0)
p2
(list (car p1) (cadr p2) 0)
)
)
(defun feng:window:addobject ( ms li / pont )
(setq li (apply 'append (MAPCAR '(LAMBDA (x) (trans x 1 0)) (REVERSE (cons (car li) (REVERSE li)))))
pont (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length li))))
)
(vlax-safearray-fill pont li)
(vla-AddPolyline ms pont)
)
(defun feng:window:lz1 ( li po ms / lw hi gr num grli nn n )
(setq lw (REVERSE (cdr (REVERSE (MAPCAR '(LAMBDA (x y) (abs (- y x))) (car (car li)) (caddr (car li))))))
hi (if (< (cadr lw) 1500) (setq hi 0) (setq hi (* (fix (/ (cadr lw) 300)) 100)))
num (* (1+ (fix (/ (car lw) 2000))) 2)
li (car li)
)
(princ "\n调整亮子高度 w->减小 s->增大，调整窗的扇数 a->减少 d->增加...")
(while (/= (car (setq gr (grread t 4 2))) 3)
(cond
((or (= (cadr gr) 65) (= (cadr gr) 97)) (if (<= num 2) (setq num 1) (setq num (- num 2))))
((or (= (cadr gr) 100) (= (cadr gr) 68)) (if (= num 1) (setq num 2) (setq num (+ num 2))))
((or (= (cadr gr) 119) (= (cadr gr) 87)) (if (<= hi 100) (setq hi 0) (setq hi (- hi 100))))
((or (= (cadr gr) 115) (= (cadr gr) 83)) (if (>= hi (- (cadr lw) 100)) (setq hi 0) (setq hi (+ hi 100))))
((= (car gr) 5) (setq po (cadr gr)))
)
(if (/= hi 0) (setq grli (list (list (MAPCAR '+ (last li) (list 50 (- hi) 0)) (MAPCAR '+ (caddr li) (list -50 (- hi) 0))))) (setq grli nil))
(setq nn (/ (car lw) num))
(repeat (setq n (1- num))
(if (= (rem n 2) 0)
(setq grli (cons (list (MAPCAR '+ (car li) (list (* nn n) 50 0)) (MAPCAR '+ (last li) (list (* nn n) -50 0))) grli))
(setq grli (cons (list (MAPCAR '+ (car li) (list (* nn n) 50 0)) (MAPCAR '+ (last li) (list (* nn n) (if (= hi 0) -50 (- hi)) 0))) grli))
)
(setq n (1- n))
)
(redraw)
(MAPCAR '(LAMBDA (x) (GRVECS (cons 2 x))) grli)
(feng:num:grvecs (list (MAPCAR '(LAMBDA (x) (rtos x 2 0)) (REVERSE (cons hi (cons nn (cons num (REVERSE lw)))))) po ))
)
(redraw)
(MAPCAR '(LAMBDA (x) (vla-addline ms (vlax-3d-point (trans (car x) 1 0)) (vlax-3d-point (trans (cadr x) 1 0)))) grli)
)
(defun c:gg ( / doc ms p1 li temp l2 *ERROR* objli )
(defun *ERROR* ( msg )
(if li (MAPCAR 'vla-Erase (car li)))
(if objli (MAPCAR 'vla-Erase objli))
(redraw)
)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
ms (vla-get-ModelSpace doc)
p1 (getpoint "\n请选择一个角点:")
li (feng:window:rec ms p1)
)
(if (null (TBLSEARCH "layer" "feng-el-window")) (vla-put-color (vla-add (vla-get-layers doc) "feng-el-window") 3))
(MAPCAR '(LAMBDA (x) (vla-put-layer x "feng-el-window")) (car li))
(MAPCAR '(LAMBDA (x) (vla-put-layer x "feng-el-window") (vla-put-color x 2)) (setq objli (feng:window:lz1 (cadr li) p1 ms)))
(princ)
)
俺不会做动态演示，有兴趣的自己试 zmzk 发表于 2024-2-21 19:59
明经里真是 藏龙卧虎，2012年 就编出 如此 不得了的程序，佩服！
太久没再写这些东西，都快看不懂自己写的是啥意思了。哈哈。。。 feng582304 发表于 2024-5-10 03:52
太久没再写这些东西，都快看不懂自己写的是啥意思了。哈哈。。。
应该是现在用不到了吧 明经里真是 藏龙卧虎，2012年 就编出 如此 不得了的程序，佩服！ 不错，来个图片
这程序怎么执行啊？ 不好意思 没注意看……好东西顶起 牛人真多，俺要好好学习一下！ 程序是写得好，实用性方面可能要差些 很好顶上……… 很好的学习资料 楼主的程序真好
能不能与来一个动态画剖切符号的啊