框选三角形边框生成面积公式

yamjqq

用海龙公式写的三角形公式不够精简，请教框选三角形边框（短线段组成）以三角形最长边为底，最长边上的高为高的三角形面积公式的lisp写法，示例见附件

cable2004

2. (defun c:tt(/ lst are)
   
3.   (if &th&
   
4.          (progn (setq th (getreal (strcat "\n输入文字高度<"  (rtos  &th& 2 2 ) ">: ")))
   
5.           (if (null th) (setq th  &th&) (setq &th& th))
   
6.    )
   
7.                 (progn  (setq th (getreal "\n请输入文字高度:<1.0>"))
   
8.           (if (null th) (setq th 1  &th& th) (setq &th& th))
   
9. ))
   
10. (setq DimZin-old (getvar "DIMZIN"))  (setvar "DIMZIN" 8)
    
11. (foreach a (vl-remove-if 'listp (mapcar 'cadr (ssnamex (setq ss (ssget '((0 . "LWPOLYLINE") (90 . 3)))))))
    
12.   (setq pts (mapcar 'cdr (vl-remove-if '(lambda (a) (/= (car a) 10)) (entget a))))
    
13.   (setq pts1 (car (vl-sort (mapcar'(lambda (x y)(list (distance x y) x y)) pts (cons (last pts)pts)) (function (lambda (e1 e2) (> (car e1) (car e2))))))
    
14.   p1 (cadr pts1)
    
15.   p2 (caddr pts1))
    
16.   (entmakex (list (cons 0 "TEXT")(cons 10 (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) p1 p2))(cons 1  (rtos (/ (fix (distance p1 p2)) 1000.0) 2 3))(cons 50 (angle p1 p2))(cons 40 th)))
    
17.   (foreach a pts  (if (or (equal (distance a p1) 0 1e-6)(equal (distance a p2) 0 1e-6)) nil (setq p3 a)))
    
18.   (entmakex (list (cons 0 "LINE")(cons 10 p3)(cons 11 (setq p33 (polar p3 (- (angle p1 p2) (/ pi 2)) (car (trans (mapcar '- p3 p1) 0 (mapcar '- p2 p1))))))(cons 62 1)))
    
19.   (entmakex (list (cons 0 "TEXT")(cons 10 (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) p3 p33))(cons 1  (rtos (/ (fix (distance p3 p33)) 1000.0) 2 3))(cons 50 (angle p3 p33))(cons 40 th)))
    
20.   (setq lst (cons (strcat "1/2*"(rtos (/ (fix (car pts1)) 1000.0) 2 3)"*" (rtos (/ (fix (distance p3 p33)) 1000.0) 2 3)) lst)
    
21.   are (cons (/ (fix (* 0.5 (distance p1 p2) (distance p3 p33))) 1000000.0) are))
    
22.   )
    
23.   (entmakex (list (cons 0 "TEXT")(cons 10 (getpoint "\n计算公式插入点"))(cons 1  (apply 'strcat (append (reverse(cdr (apply 'append (mapcar'(lambda (a)(list "+" a)) lst)))) (list "=" (rtos (apply '+ are) 2 3)))))(cons 40 th)))
    
24.   
    
25. (setvar "DIMZIN" DimZin-old)      
    
26.   (princ))

(defun c:tt(/ lst are)<br />   (if &th&<br />          (progn (setq th (getreal (strcat "\n输入文字高度<"  (rtos  &th& 2 2 ) ">: ")))<br />           (if (null th) (setq th  &th&) (setq &th& th))<br />    )<br />                 (progn  (setq th (getreal "\n请输入文字高度:<1.0>"))<br />           (if (null th) (setq th 1  &th& th) (setq &th& th))<br /> ))<br /> (setq DimZin-old (getvar "DIMZIN"))  (setvar "DIMZIN" 8)<br /> (foreach a (vl-remove-if 'listp (mapcar 'cadr (ssnamex (setq ss (ssget '((0 . "LWPOLYLINE") (90 . 3)))))))<br />   (setq pts (mapcar 'cdr (vl-remove-if '(lambda (a) (/= (car a) 10)) (entget a))))<br />   (setq pts1 (car (vl-sort (mapcar'(lambda (x y)(list (distance x y) x y)) pts (cons (last pts)pts)) (function (lambda (e1 e2) (> (car e1) (car e2))))))<br />   p1 (cadr pts1)<br />   p2 (caddr pts1))<br />   (entmakex (list (cons 0 "TEXT")(cons 10 (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) p1 p2))(cons 1  (rtos (/ (fix (distance p1 p2)) 1000.0) 2 3))(cons 50 (angle p1 p2))(cons 40 th)))<br />   (foreach a pts  (if (or (equal (distance a p1) 0 1e-6)(equal (distance a p2) 0 1e-6)) nil (setq p3 a)))<br />   (entmakex (list (cons 0 "LINE")(cons 10 p3)(cons 11 (setq p33 (polar p3 (- (angle p1 p2) (/ pi 2)) (car (trans (mapcar '- p3 p1) 0 (mapcar '- p2 p1))))))(cons 62 1)))<br />   (entmakex (list (cons 0 "TEXT")(cons 10 (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) p3 p33))(cons 1  (rtos (/ (fix (distance p3 p33)) 1000.0) 2 3))(cons 50 (angle p3 p33))(cons 40 th)))<br />   (setq lst (cons (strcat "1/2*"(rtos (/ (fix (car pts1)) 1000.0) 2 3)"*" (rtos (/ (fix (distance p3 p33)) 1000.0) 2 3)) lst)<br />   are (cons (/ (fix (* 0.5 (distance p1 p2) (distance p3 p33))) 1000000.0) are))<br />   )<br />   (entmakex (list (cons 0 "TEXT")(cons 10 (getpoint "\n计算公式插入点"))(cons 1  (apply 'strcat (append (reverse(cdr (apply 'append (mapcar'(lambda (a)(list "+" a)) lst)))) (list "=" (rtos (apply '+ are) 2 3)))))(cons 40 th)))<br />   <br /> (setvar "DIMZIN" DimZin-old)       <br />   (princ))

yamjqq

谢谢cable2004老师的指导。