【源码】平行四边形

;;;绘制平行四边形;;;xuyanyan;;;2025.10编写(vl-load-com);;;(1)点距离比较(defun pickl(ptlst pt0 / i dstlst mi)  (setq i 0 dstlst nil)  (repeat(1-(length ptlst))    (setq dstlst(cons(+(distance pt0 (nth i ptlst))(distance pt0 (nth (1+ i)ptlst)))dstlst)	  i (1+ i)))  (setq dstlst (reverse dstlst)	 mi(car(vl-sort-i dstlst '<)))  (list(append(nth mi ptlst)(list 0.0))(append(nth(1+ mi)ptlst)(list 0.0))));;;(2)获取线段或多线的端点坐标(defun GetVertx(ent_name clckpt / ent_data obj_type start_point end_point vertices)    (setq ent_data (entget ent_name))    (setq obj_type (cdr (assoc 0 ent_data)))    (cond        ; 处理直线        ((= obj_type "LINE")            (setq start_point (cdr (assoc 10 ent_data)))  ; 起点            (setq end_point (cdr (assoc 11 ent_data)))    ; 终点            (list start_point end_point))        ; 处理轻量多段线        ((= obj_type "LWPOLYLINE")            (setq vertices '())            ; 收集所有顶点            (foreach code ent_data                (if (= (car code) 10)                    (setq vertices (cons (cdr code)vertices))))            (setq vertices (reverse vertices))            ; 返回首尾端点            (pickl vertices clckpt))        ; 处理旧式多段线        ((= obj_type "POLYLINE")            (setq vertices '())            (setq next_ent (entnext ent_name))            ; 遍历顶点子实体            (while (and next_ent (= (cdr (assoc 0 (entget next_ent))) "VERTEX"))                (setq vertices (cons (cdr (assoc 10 (entget next_ent))) vertices))                (setq next_ent (entnext next_ent)))            (setq vertices (reverse vertices))            ; 返回首尾端点            (if vertices                (pickl vertices clckpt)                nil))        ; 不支持的类型        (T nil)));;;(3求两直线的交点(defun GetInters(/ ent1 ent2 endpoints)  (setq ent1 (entsel "\n选择第一条线段: "))  (if ent1        (progn            (setq endpoints(GetVertx(car ent1)(cadr ent1)))            (if endpoints                (progn                    (setq p1(car endpoints)			  p2(cadr endpoints)))                (princ "\n无法获取该实体的端点坐标!")))        (princ "\n未选择对象!"))  (setq ent2(entsel "\n选择第二条线段: "))  (if ent2        (progn            (setq endpoints(GetVertx(car ent2)(cadr ent2)))            (if endpoints                (progn                    (setq p3 (car endpoints)			  p4 (cadr endpoints)))                (princ "\n无法获取该实体的端点坐标!")))        (princ "\n未选择对象!"))    (if (and ent1 ent2)            (setq ints (inters p1 p2 p3 p4 nil))));;;(4)平行四边形三点求第四点坐标(defun 4thPt(pt1 pt2 pt3 / d1 d2 dd 4p)  (setq d1 (mapcar'- pt1 pt2)	d2 (mapcar'- pt3 pt2)	dd (mapcar'+ d1 d2)	4p (mapcar'+ pt2 dd)));;;(7)平行四边形绘图函数(defun plgram(pt1 pt2 pt3 pt4)(regapp "XYY")(entmake(append(list'(0 . "LWPOLYLINE")		     '(100 . "AcDbEntity")		     '(100 . "AcDbPolyline")		     '(62 . 1)		     '(90 . 4)		     '(70 . 1)		 (cons 10 pt1)		 (cons 10 pt2)		 (cons 10 pt3)		 (cons 10 pt4))(list (list -3(list "XYY"(cons 1000 "paralgram")))))));;;(5)平行四边形的绘制(defun c:PARALG( / ctrl p1 p2 p3 p4 pp1 pp2 pp3 pp4 osmode_b)  (setq osmode_b (getvar "osmode"))  (setvar "osmode" 1)(initget"i I")  (setq ctrl(getpoint"\n拾取平行四边形三点或 [交叉线(I)]:"))  (if (or(= ctrl "I")(= ctrl "i"))    (progn      (GetInters)      (setq pp1 (4thpt p1 ints p3)	    pp2 (4thpt p1 ints p4)	    pp3 (4thpt p2 ints p4)	    pp4 (4thpt p2 ints p3)))    (progn      (setq pp1 ctrl	    pp2 (getpoint"\n 指定第二点：")	    pp3 (getpoint"\n 指定第三点：")	    pp4 (4thpt pp1 pp2 pp3))))  (plgram pp1 pp2 pp3 pp4)    (princ(strcat"\n  ******* 角 点 坐 标 表 *******"		 "\n   1#," (rtos(car pp1)2 3)","(rtos(cadr pp1)2 3)		 "\n   2#," (rtos(car pp2)2 3)","(rtos(cadr pp2)2 3)		 "\n   3#," (rtos(car pp3)2 3)","(rtos(cadr pp3)2 3)		 "\n   4#," (rtos(car pp4)2 3)","(rtos(cadr pp4)2 3)		 "\n  ******************************"))    (entmake (list '(0 . "TEXT") (cons 1 "1#") (cons 10 pp1) (cons 40 1)))    (entmake (list '(0 . "TEXT") (cons 1 "2#") (cons 10 pp2) (cons 40 1)))    (entmake (list '(0 . "TEXT") (cons 1 "3#") (cons 10 pp3) (cons 40 1)))    (entmake (list '(0 . "TEXT") (cons 1 "4#") (cons 10 pp4) (cons 40 1)))  (setvar "osmode" osmode_b)  (princ))(prompt "\n***输入\"PARALG\"命令进行绘图***")