cad四边形展开lisp_批量绘制四边形 - AutoLISP/Visual LISP 编程技术 - CAD论坛 - 明经CAD社区 - Powered by Discuz!...

;试用以下程序

(defun c:test()

(setq bcsjb '(("A1" 9549.31 6977.53 7180.75 7155.97 11015.11)

("A2" 10814.00 7468.76 6367.24 7155.97 11072.28)

("A3" 4563.99 6621.92 6732.4        7155.97        10938.9)

("A4" 4911.96 6422.68 11368.55 7538.32 10932.26)

)

)

(setq cmd (getvar "cmdecho"))

(setq osm (getvar "osmode"))

(setvar "cmdecho" 0)

(setvar "osmode" 0)

(command "_undo" "be")

(setq ljc 0.0)

(setq i 0)

(setq n (length bcsjb))

(repeat n

(setq sjb (nth i bcsjb))

(mapcar 'set '(zfc c a d e b) sjb)

(setq CosA (/ (- (+ (* b b) (* c c)) (* a a)) 2.0 b c))

(setq jdA (atan (/ (sqrt (- 1.0 (* CosA CosA))) CosA )))

(setq p1 (list ljc 0))

(setq p2 (mapcar '+ p1 (list c 0)))

(setq p3 (polar p1 jdA b))

(setq CosB (/ (- (+ (* b b) (* e e)) (* d d)) 2.0 b e))

(setq jdB (atan (/ (sqrt (- 1.0 (* CosB CosB))) CosB)))

(setq p4 (polar p1 (+ jdA jdB) e))

(setq pmid (mapcar '(lambda(x y)(* 0.5 (+ x y))) p1 p3))

(command "_pline" p1 p2 p3 p4 "c")

(command "_text" pmid 1000 0 zfc)

(setq ptmin (apply 'mapcar (cons 'min (list p1 p2 p3 p4))))

(setq ptmax (apply 'mapcar (cons 'max (list p1 p2 p3 p4))))

(setq dxy (mapcar '- ptmax ptmin))

(setq ljc (+ ljc (car dxy) 2000.0))

(setq i (1+ i))

)

(command "_undo" "e")

(setvar "osmode" osm)

(setvar "cmdecho" cmd)

(princ)

)