有人说，这个还不错

自贡黄明儒 · 发表于 2022-12-9 15:51

本帖最后由自贡黄明儒于 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
gx 0.0
gy 0.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))
(setq angS (list -15 0 15 30 45 60 75 90 105 120
135 150 165 180 195 210 225 240 255 270
285 300 315 330 345 360 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
(setq pts1
(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各连线无交点的点
(setq pts1 ;多段线上点向p1 p2方向画垂线
(mapcar (function
(lambda (x)
(polar x ang 100)
)
)
pts
)
)
;;pts到p1-p2垂点
(setq pts1 (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))
;;记录没有交点的垂点
(if L
nil
(setq L1 (cons (car a) L1))
)
)
;到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的垂点
(setq pts1
(mapcar (function
(lambda (x)
(polar x ang 100)
)
)
L1
)
)
;;pts到p1-p2垂点
(setq pts1 (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)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;点集质心 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 
        gx  0.0 
        gy  0.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)) 
  (setq  angS (list -15  0    15    30   45   60   75   90   105  120 
       135  150  165  180  195  210   225  240  255  270 
       285  300  315  330  345  360   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 
  (setq  pts1 
   (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各连线无交点的点 
  (setq  pts1        ;多段线上点向p1 p2方向画垂线 
   (mapcar (function 
       (lambda (x) 
         (polar x ang 100) 
       ) 
     ) 
     pts 
   ) 
  ) 
  ;;pts到p1-p2垂点 
  (setq  pts1 (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)) 
    ;;记录没有交点的垂点 
    (if  L 
      nil 
      (setq L1 (cons (car a) L1)) 
    ) 
  ) 
 
  ;<img src="static/image/smiley/default/titter.gif" smilieid="9" border="0" alt="" />到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的垂点 
  (setq  pts1 
   (mapcar (function 
       (lambda (x) 
         (polar x ang 100) 
       ) 
     ) 
     L1 
   ) 
  ) 
  ;;pts到p1-p2垂点 
  (setq  pts1 (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) 
)

顺便说一下，上面说的“有人”，是“友人”，更可能是“王婆”

llsheng_73 · 发表于 2022-12-13 17:23

本帖最后由 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))
))

(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(
          (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)) 
        ))

没有象黄老师那样搞自动参考线，需要自己通过两点确定参考方向，也没有计算所需要的参考线长度

菜卷鱼 · 发表于 2022-12-9 17:30

跟我很多年前写的投影，有点类似，但是老黄这个强一点，各个方向都支持
简单的投影程序
http://bbs.mjtd.com/forum.php?mo ... &fromuid=399892
(出处: 明经CAD社区)

hkhbs · 发表于 2022-12-9 16:05

谢谢！很厉害

hkhbs · 发表于 2022-12-9 16:17

错误: 除数为零操作有什么条件吗

hkhbs · 发表于 2022-12-9 16:33

可以了画的线形问题谢谢

gdfyhao · 发表于 2022-12-9 16:45

好厉害，实时绘图很强大

229096767 · 发表于 2022-12-9 18:32

谢谢分享 ,学习一下

中国梦 · 发表于 2022-12-9 20:15

谢谢分享 ,学习一下

LYC688 · 发表于 2022-12-10 08:54

666666666666666666666

嘉伟钢结构 · 发表于 2022-12-12 12:09

老师：快捷命令是什么？

账号		自动登录	找回密码
密码			注册

[讨论] 有人说，这个还不错

本帖子中包含更多资源

评分

本帖被以下淘专辑推荐:

本帖子中包含更多资源

点评

评分

点评