批量多段线反向

GDFGFGF 发表于 2020-12-11 18:56:26

本帖最后由 GDFGFGF 于 2020-12-25 10:58 编辑

已解决

yarp 发表于 2020-12-12 23:22:26

(defun *error* ( info / )
(princ)
)

(defun loc:poly-area (points / ;;;;{{{
      nexts ) ;;;取得由顺序点构成的多边形的面积
(if (not
(apply 'and
      (mapcar '=
      (car points)
      (car (reverse points))
      )
      )
)
(setq points (cons (car (reverse points)) points))
)
(setq nexts (cdr points))
(/ (apply '+ (mapcar
'(lambda (a b)
   (- (* (car a) (cadr b))
      (* (car b) (cadr a))
      )
   )
points
nexts
)
   )
2)
) ;;;;}}}

(defun loc:curve-area ( curve-ent / ;{{{
loc:range obj points point p-num coord
a b c d)

(defun loc:range ( i / k j)
(setq k -1)
(setq j '())
(repeat i
   (setq k (1+ k))
   (setq j (cons k j))
   )
(reverse j)
)

(setq obj (vlax-ename->vla-object curve-ent))
(setq points (vla-get-coordinates obj))
(setq points (vlax-safearray->list
(vlax-variant-value points)
)
)
(setq point (vla-get-coordinate obj 0))
(setq point (vlax-safearray->list
(vlax-variant-value point)
)
)
(setq p-num (/ (length points) (length point)))
(setq p-num (loc:range p-num))
(setq coord
(mapcar
   '(lambda (a b)
      (list (nth a points) (nth b points))
      )
   (mapcar
   '(lambda (c)
      (* c (length point))
      )
   p-num
   )
   (mapcar
   '(lambda (d)
      (1+
(* d (length point))
)
      )
   p-num
   )
   )
)
(loc:poly-area coord)
);}}}

(defun loc:reverse-curve ( curve-ent / ;;;;{{{
loc:range obj points point p-num coord
a b c d)

(defun loc:range ( i / k j)
(setq k -1)
(setq j '())
(repeat i
   (setq k (1+ k))
   (setq j (cons k j))
   )
(reverse j)
)

(setq obj (vlax-ename->vla-object curve-ent))
(setq points (vla-get-coordinates obj))
(setq points (vlax-safearray->list
(vlax-variant-value points)
)
)
(setq point (vla-get-coordinate obj 0))
(setq point (vlax-safearray->list
(vlax-variant-value point)
)
)
(if ( > (length point) 2)
(progn
   (princ "输入的多线不是平面多线，退出...")
   (exit)
   )
)
(setq p-num (/ (length points) (length point)))
(setq p-num (loc:range p-num))
(setq coord
(mapcar
   '(lambda (a b)
      (list (nth a points) (nth b points))
      )
   (mapcar
   '(lambda (c)
      (* c (length point))
      )
   p-num
   )
   (mapcar
   '(lambda (d)
      (1+
(* d (length point))
)
      )
   p-num
   )
   )
)
(setq coord (reverse coord))
(setq coord (apply 'append coord))
(setq coord (vlax-make-variant
(vlax-safearray-fill
   (vlax-make-safearray
   vlax-vbDouble
   (cons 0 (1- (length coord)))
   )
   coord
   )
)
)
(vla-put-coordinates obj coord)
(princ)
) ;;;;}}}

(defun c:tt (/ ;;;;{{{
      ent obj
      )
(vl-load-com)
(princ "\n请选择曲线:")
(and
(setq ent (car (entsel)))
(setq obj (vlax-ename->vla-object ent))
(eq "AcDbPolyline" (vla-get-objectname obj))
(> (loc:curve-area ent) 0) ;;;改成小于号就是逆时针
(loc:reverse-curve ent)
)
) ;;;;}}}

图纸打不开，没测试

GDFGFGF 发表于 2020-12-13 11:46:26

yarp 发表于 2020-12-12 23:22
图纸打不开，没测试

好的谢谢图纸重发了

GDFGFGF 发表于 2020-12-13 11:54:45

yarp 发表于 2020-12-12 23:22
图纸打不开，没测试

改程序只能单选，要能框选最好，其次我要的是图片左边混乱的起点终点排序通过程序批量改为图片右边统一的顺序。虽然没达到想要的结果，不过也要谢谢你的热心肠

yarp 发表于 2020-12-14 11:55:11

有时间给你升级来转一转。

bai2000 发表于 2020-12-25 09:03:58

楼上，在等你的lisp啊

yarp 发表于 2021-1-4 23:30:35

bai2000 发表于 2020-12-25 09:03
楼上，在等你的lisp啊

(defun *error* ( info / )
(princ)
)

(defun loc:poly-area (points / ;;;;{{{
                           nexts ) ;;;取得由顺序点构成的多边形的面积
(if (not
      (apply 'and
            (mapcar '=
                     (car points)
                     (car (reverse points))
                     )
            )
      )
(setq points (cons (car (reverse points)) points))
)
(setq nexts (cdr points))
(/ (apply '+ (mapcar
               '(lambda (a b)
                  (- (* (car a) (cadr b))
                     (* (car b) (cadr a))
                     )
                  )
               points
               nexts
               )
         )
   2)
) ;;;;}}}

(defun loc:curve-area ( curve-ent / ;{{{
            loc:range obj points point p-num coord
            a b c d)

(defun loc:range ( i / k j)
(setq k -1)
(setq j '())
(repeat i
         (setq k (1+ k))
         (setq j (cons k j))
         )
(reverse j)
)

(setq obj (vlax-ename->vla-object curve-ent))
(setq points (vla-get-coordinates obj))
(setq points (vlax-safearray->list
               (vlax-variant-value points)
               )
      )
(setq point (vla-get-coordinate obj 0))
(setq point (vlax-safearray->list
            (vlax-variant-value point)
            )
      )
(setq p-num (/ (length points) (length point)))
(setq p-num (loc:range p-num))
(setq coord
      (mapcar
      '(lambda (a b)
         (list (nth a points) (nth b points))
         )
      (mapcar
         '(lambda (c)
            (* c (length point))
            )
         p-num
         )
      (mapcar
         '(lambda (d)
            (1+
            (* d (length point))
            )
            )
         p-num
         )
      )
      )
(loc:poly-area coord)
);}}}

(defun loc:reverse-curve ( curve-ent dir corner-func / ;;;;{{{
            loc:range obj points point p-num coord
            a b c d)

(defun loc:range ( i / k j)
(setq k -1)
(setq j '())
(repeat i
         (setq k (1+ k))
         (setq j (cons k j))
         )
(reverse j)
)

(setq obj (vlax-ename->vla-object curve-ent))
(setq points (vla-get-coordinates obj))
(setq points (vlax-safearray->list
               (vlax-variant-value points)
               )
      )
(setq point (vla-get-coordinate obj 0))
(setq point (vlax-safearray->list
            (vlax-variant-value point)
            )
      )
(if ( > (length point) 2)
(progn
   (princ "输入的多线不是平面多线，退出...")
   (exit)
   )
)
(setq p-num (/ (length points) (length point)))
(setq p-num (loc:range p-num))
(setq coord
      (mapcar
      '(lambda (a b)
         (list (nth a points) (nth b points))
         )
      (mapcar
         '(lambda (c)
            (* c (length point))
            )
         p-num
         )
      (mapcar
         '(lambda (d)
            (1+
            (* d (length point))
            )
            )
         p-num
         )
      )
      )
(if dir
(setq coord (reverse coord))
)
(setq coord (loc:rotate-point coord corner-func))
(setq coord (apply 'append coord))
(setq coord (vlax-make-variant
            (vlax-safearray-fill
               (vlax-make-safearray
                  vlax-vbDouble
                  (cons 0 (1- (length coord)))
                  )
               coord
               )
            )
      )

(vla-put-coordinates obj coord)
(princ)
) ;;;;}}}

(defun c:tt (/ ;;;;{{{
            ent obj
            )
(vl-load-com)
(initget 1 "lu ld ru rd")
(setq kwd (getkword "请输入线段起点在那个角 lu ld ru rd"))
(setq func-list (mapcar 'cons (list "lu" "ld" "ru" "rd")
   (list loc:lu loc:ld loc:ru loc:rd)
   ))
(setq coner-func (cdr (assoc kwd func-list)))
(princ "\n请选择曲线:")
(and
(setq ent (car (entsel)))
(setq obj (vlax-ename->vla-object ent))
(eq "AcDbPolyline" (vla-get-objectname obj))
(if (> (loc:curve-area ent) 0) ;;;改成小于号就是逆时针
(loc:reverse-curve ent t coner-func)
   (loc:reverse-curve ent nil coner-func)
   )
)
) ;;;;}}}

(defun loc:lu ( pt / ;{{{
   )
(* (- 0 (car pt)) (cadr pt))
);}}}

(defun loc:ru ( pt /;{{{
   )
(* (car pt) (cadr pt))
);}}}

(defun loc:ld ( pt / ;{{{
   )
(* (- 0 (car pt)) (- 0 (cadr pt)))
);}}}

(defun loc:rd ( pt / ;{{{
   )
(* (car pt) (- 0 (cadr pt)))
);}}}

(defun loc:rotate-point ( pts meth / ;{{{
      )
(setq corner-value (apply 'max (mapcar 'meth pts)))
(setq mark nil)
(mapcar
(function (lambda (a)
(if (and (/= (meth a) corner-value) (not mark))
   (progn
   (setq pts (append (cdr pts) (list (car pts))))
   )
   (progn
   (setq mark t)
   )
   )
)
      )
pts)
pts
);}}}

可能有点bug，有问题自行调试哈。

bai2000 发表于 2021-1-5 12:52:44

不能框选

GDFGFGF 发表于 2021-1-5 17:15:51

批量改变多段线的起点和终点 - AutoLISP/Visual LISP 编程技术 - CAD论坛 - 明经CAD社区 - Powered by Discuz!http://bbs.mjtd.com/thread-182796-1-1.html

页: [1]

明经CAD社区's Archiver

批量多段线反向