有人说，这个还不错
本帖最后由 自贡黄明儒 于 2022-12-14 11:59 编辑在QQ上发布了这个，其实没什么用处。有人说，这个还不错，那就分享给大家
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;点集质心 by csharp
;;点集数量大于3个，不能交叉，不能共线
(defun xd::pnts:centroid (pts / x0 y0 s gx gy x1 x2 y1 y2 tmp)
(setq x0(caar pts)
y0(cadar pts)
pts (cdr pts)
s 0.0
gx0.0
gy0.0
)
(while (cdr pts)
(setq x1(caar pts)
y1(cadar pts)
x2(caadr pts)
y2(cadadr pts)
tmp (- (* (- x1 x0) (- y2 y0)) (* (- x2 x0) (- y1 y0)))
s (+ s tmp)
gx(+ gx (* tmp (/ (+ x0 x1 x2) 3.0)))
gy(+ gy (* tmp (/ (+ y0 y1 y2) 3.0)))
)
(setq pts (cdr pts))
)
(list (/ gx s) (/ gy s) 0.0)
)
;;点集最远2点 MJ:lensort
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;点集质心 by csharp
;;3 多段线顶点
;;(_HH:GetLwPts (car(entsel)))=>((1.0 0.0) (1.0 1.0) (0.0 1.0) (0.0 0.0))
(defun _HH:GetLwPts (e / PTS)
(foreach x (entget e)
(if(= (car x) 10)
(setq pts (cons (cdr x) pts))
)
)
(reverse pts)
)
;;判断点是否在矩形内;pts(左下角 右上角)
(defun PInRectang-p (pts p / LD RU)
(setq LD (car pts))
(setq RU (cadr pts))
(and
(<= (car LD) (car p) (car RU))
(<= (cadr LD) (cadr p) (cadr RU))
)
)
;;;-----------------------------------------------------------;;
;;; 旋转向量到指定角度 ;;
;;; 输入: 一个向量和指定的角度 ;;
;;; 输出: 被旋转后的向量 ;;
;;;-----------------------------------------------------------;;
(defun MAT:Rot2D (v a / c s x y)
(setq c (cos a) s (sin a))
(setq x (car v) y (cadr v))
(list (- (* x c) (* y s)) (+ (* x s) (* y c)))
)
;;;----------------------------------------------------;
;;;功能: 以基点旋转一点到指定的角度 ;
;;;输入: 要旋转的点Pt，基点和旋转角度 ;
;;;输出: 旋转后点位置 ;
;;;----------------------------------------------------;
(defun GEO:Rot2D (Pt PtBase Ang)
(mapcar '+ PtBase (MAT:Rot2D (mapcar '- Pt PtBase) Ang))
)
;;p不在包围盒内，中心点Cen超出到P的角度决定
(defun x11 (Cen p pts / A ANG ANG1 ANGS ANGS1 CEN D I L L1 LD P1 P2 PTS1 PTS2 PTS3 RU X Y)
;;圆整角度
(setq ang (angle Cen p))
(setq ang1 (/ (* ang 180) pi))
(setqangS (list -150 15 30 45 60 75 90 105120
135150165180195210 225240255270
285300315330345360 375
)
)
(setq angS1 (mapcar '(lambda (x y) (* (+ x y) 0.5)) angS (cdr angS)))
(setq angS1 (mapcar '(lambda (x y) (<= x ang1 y)) angS1 (cdr angS1)))
(setq i (1+ (VL-POSITION T angS1)))
(setq ang (nth i angS))
(if (= ang 360)
(setq ang 0)
)
(setq ang (/ (* pi ang) 180))
;;点集pts绕Cen顺时针旋转ang
(setqpts1
(mapcar (function
(lambda (x) (GEO:Rot2D x Cen (- ang)))
)
pts
)
)
;;最小 最大点
(setq LD (apply 'mapcar (cons 'min pts1)))
(setq RU (apply 'mapcar (cons 'max pts1)))
(setq p1 (list (car RU) (cadr LD)))
(setq p2 RU)
;;p1 p2转回去
(setq p1 (GEO:Rot2D p1 Cen ang))
(setq p2 (GEO:Rot2D p2 Cen ang))
;;pts到p1-p2垂点，且不与pts各连线无交点的点
(setqpts1 ;多段线上点向p1 p2方向画垂线
(mapcar (function
(lambda (x)
(polar x ang 100)
)
)
pts
)
)
;;pts到p1-p2垂点
(setqpts1 (mapcar (function
(lambda (x y) (list y (inters p1 p2 x y nil)))
)
pts1
pts
)
)
(setq pts2 (cons (last pts) pts))
(setq pts3 pts)
(setq L1 nil)
(foreach a pts1 ;a(多段线上点 垂点)
(setq
L
(mapcar (function (lambda (x y) (inters (car a) (cadr a) x y)))
pts2
pts3
)
)
;;去掉多段线本身的点，由于计算误差，可能去不掉
(foreach x pts
(setq L (mapcar '(lambda (y)
(if (equal x y 0.00001)
nil
y
)
)
L
)
)
)
(setq L (VL-REMOVE nil L))
;;记录没有交点的垂点
(ifL
nil
(setq L1 (cons (car a) L1))
)
)
;;P到p1 p2的距离
(setq d (car (trans (mapcar '- p p1) 0 (mapcar '- p2 p1))))
(setq d (abs d))
;;新p1 p2
(setq p1 (polar p1 ang d))
(setq p2 (polar p2 ang d))
;;L1线上的点，画出到P1P2的垂点
(setqpts1
(mapcar (function
(lambda (x)
(polar x ang 100)
)
)
L1
)
)
;;pts到p1-p2垂点
(setqpts1 (mapcar (function
(lambda (x y) (list y (inters p1 p2 x y nil)))
)
pts1
L1
)
)
(grdraw p1 p2 1 1)
(mapcar (function (lambda (x) (grdraw (car x) (cadr x) 1 1)))
pts1
)
pts1
)
;;画轴测图
(defun x1 (e / CEN LD P PTS RU pts1)
;;顶点坐标
(setq pts (_HH:GetLwPts e))
;;质心
(setq Cen (xd::pnts:centroid pts))
;;最小 最大点
(setq LD (apply 'mapcar (cons 'min pts)))
(setq RU (apply 'mapcar (cons 'max pts)))
(WHILE (and (setq TMP (grread t 4 2))
(setq mode (car TMP))
(not (or (equal mode 3);鼠标左键
(equal mode 11);鼠标右键,右键设置为回车时
(equal mode 25);鼠标右键,右键设置为屏幕菜单时
(equal TMP '(2 13));回车，不能用=
(equal TMP '(2 32));空格，不能用=
)
)
)
(setq pts1 nil)
(redraw)
(setq p (cadr TMP)) ;鼠标位置p
(if(PInRectang-p (list LD RU) p)
(mapcar (function (lambda (x) (grdraw x p 1 1))) pts)
(setq pts1 (x11 Cen p pts))
)
)
(if pts1
(mapcar
(function
(lambda(x)
(entmakeX
(list '(0 . "LINE") (cons 10 (car x)) (cons 11 (cadr x)))
)
)
)
pts1
)
)
)
(defun C:x1 (/ E)
(setq e (car (entsel)))
(x1 e)
(princ)
)
顺便说一下，上面说的“有人”，是“友人”，更可能是“王婆”:lol
本帖最后由 llsheng_73 于 2022-12-13 17:53 编辑
20060510412 发表于 2022-12-12 12:30
请教黄大师，对于非封闭的图元，当向上投影的时候，得到上面的形状。
能否改为下面的形状呢？
(vl-load-com)
(defun xyofen(e fun / p i pt n en)
(or(=(type e)'ename)(setq e(vlax-vla-object->ename e)))
(cond((vl-position'(0 . "LINE")(setq en(entget e)))
(list(vlax-curve-getstartpoint e)(vlax-curve-getendpoint e)))
((WCMATCH(cdr(assoc 0 en))"*POLYLINE")
(setq i -1 n(vlax-curve-getEndParam e))
(while(< i n)
(setq i(1+ i)p(vlax-curve-getPointAtParam e i))
(or(equal(car pt)p fun)(setq pt(cons p pt))))
(reverse pt))
(t(vl-remove'nil(mapcar'(lambda(x)(cdr(assoc x en)))'(10 11 12 13 14))))))
(defun s2e(s / n lst)(if(=(type s)'pickset)(repeat(setq n(sslength s))(setq n(1- n)lst(cons(ssname s n)lst)))))
(defun PerLn(p p1 p2);;;点p到p1,p2所在直线垂距及垂足
(setq p2(mapcar'- p1 p2))
(list(abs(car(trans(mapcar'- p1 p) 0 p2)))
(trans(mapcar'+(mapcar'*'(1 1 0)(trans p1 0 p2))(mapcar'*'(0 0 1)(trans p 0 p2)))p2 0)))
(defun delsame(l1 fuz / l2);;带容差去重(重复过的取第一次出现)
(while l1(setq l2(cons(car l1)l2)l1(vl-remove-if'(lambda (x)(equal(car l1)x fuz))(cdr l1))))
(reverse l2))
(defun ScreenWid();;当前屏幕宽度
(*(apply'/(getvar'screensize))(getvar'viewsize)))
(defun c:tt(/ s pt pts p o w ls)
(while(setq s(s2e(ssget)))
(and(setq a nil pt nil o(getpoint"指定参考线上一点"))
(vl-every(function(lambda(x)(setq pt(cons(xyofen x 1e-3)pt))))s)
(setq pts(delsame(apply(function append)pt)1e-3))
(while(/=(car(mapcar(function set)'(a p)(grread 5)))3)(redraw)
(setq ls nil)
(if(= a 5)
(progn
(grdraw(polar o(angle p o)(setq w(ScreenWid)))(polar p(angle o p)w)5)
(vl-some(function(lambda(x / q s)
(setq q(cadr(PerLn x p o)))
(or(vl-some(function(lambda(a)
(vl-some(function(lambda(a b / o)(and(setq o(inters x q a b))(not(equal x o 1e-3)))))a(cdr a))))pt)
(grdraw x q 4)
(setq ls(cons(list x q)ls)))nil))pts)))))
(if(= a 3)(vl-every(function(lambda(x)(entmakex(list'(0 . "line")(cons 10(car x))(cons 11(cadr x))'(62 . 4)))))ls))
))
没有象黄老师那样搞自动参考线，需要自己通过两点确定参考方向，也没有计算所需要的参考线长度
跟我很多年前写的投影，有点类似，但是老黄这个强一点，各个方向都支持
简单的投影程序
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=108980&fromuid=399892
(出处: 明经CAD社区)
谢谢！很厉害 错误: 除数为零 操作 有什么条件吗 可以了 画的线形问题 谢谢 好厉害，实时绘图很强大 谢谢分享 ,学习一下
谢谢分享 ,学习一下 666666666666666666666 老师：快捷命令是什么？
页:
[1]
2