多段线反向

邹锋 · 发表于 2015-7-7 21:37

好像我搜索到有呀，反向的，不用CAD命令的

邹锋 · 发表于 2015-7-7 21:39

;;;;方向转换****************************************************
(defun VxRevPline (Obj / BlgLst ObjName PntLst SegCnt TmpLst Ubound)
  (setq Obj (vlax-ename->vla-object en))
  (setq ObjName (vlax-get Obj 'ObjectName)
TmpLst (vlax-get Obj 'Coordinates)
  ) ;_ 结束setq
  (if (eq ObjName "AcDbPolyline")
(repeat (/ (length TmpLst) 2)
   (setq PntLst (cons (list (car TmpLst) (cadr TmpLst)) PntLst)
      TmpLst (cddr TmpLst)
   ) ;_ 结束setq
) ;_ 结束repeat
(repeat (/ (length TmpLst) 3)
   (setq PntLst (cons (list (car TmpLst) (cadr TmpLst) (caddr TmpLst))
   PntLst
   ) ;_ 结束cons
      TmpLst (cdddr TmpLst)
   ) ;_ 结束setq
) ;_ 结束repeat
  ) ;_ 结束if
  (vlax-put Obj 'Coordinates (apply 'append PntLst))
  (if (not (eq ObjNme "AcDb3dPolyline"))
(progn
   (setq Ubound (1- (length PntLst))
      BlgLst (list (* (vla-GetBulge Obj Ubound) -1))
      SegCnt 0
   ) ;_ 结束setq
   (repeat Ubound
(setq BlgLst (cons (* (vla-GetBulge Obj SegCnt) -1) BlgLst)
      SegCnt (1+ SegCnt)
) ;_ 结束setq
   ) ;_ 结束repeat
   (setq SegCnt 0)
   (foreach memb BlgLst
(vla-SetBulge Obj SegCnt memb)
(setq SegCnt (1+ SegCnt))
   ) ;_ 结束foreach
) ;_ 结束progn
  ) ;_ 结束if
  (vla-Update Obj)
  Obj
) ;_ 结束defun

长老发给我的，，不是我自己的，

自贡黄明儒 · 发表于 2015-7-8 08:05

邹锋发表于 2015-7-7 21:39
;;;;方向转换****************************************************
(defun VxRevPline (Obj / BlgLst Ob ...

写得不错，同命令REVERSE还是有区别的

tangjunasd58 · 发表于 2015-7-10 15:12

看看是什么样的，顶下

stoyer · 发表于 2015-7-10 17:26

这个遇到弧段的多段线怎么办?

自贡黄明儒 · 发表于 2015-7-11 12:05

本帖最后由自贡黄明儒于 2015-7-13 09:48 编辑

邹锋发表于 2015-7-7 21:39
;;;;方向转换****************************************************
(defun VxRevPline (Obj / BlgLst Ob ...

;;这个更接近Autocad本身的命令reverse
;;多段线反向
;;(VxRevPline (car(entsel)))
(defun VxRevPline (e / A B EW L2 LST N OBJ OBJNAME OBJNME PNTLST SW TMPLST X)
  (setq Obj (vlax-ename->vla-object e))
  (setq       ObjName       (vlax-get Obj 'ObjectName)
      TmpLst       (vlax-get Obj 'Coordinates)
  )
  (repeat (/ (length TmpLst) 2)
(setq PntLst (cons (list (car TmpLst) (cadr TmpLst)) PntLst)
      TmpLst (cddr TmpLst)
)
  )
  (vlax-put Obj 'Coordinates (apply 'append PntLst))
  (cond
((not (eq ObjNme "AcDb3dPolyline"))
   (repeat (setq n (length PntLst))
   (setq x (vla-GetBulge Obj (setq n (1- n))))
   (setq Lst (cons x Lst))
   (vla-GetWidth Obj n 'sw 'ew)
   (setq L2 (cons (list n sw ew) L2))
   )
   (setq Lst (reverse Lst))
   (setq L2 (reverse L2))
   (setq a (car Lst))
   (setq b (car L2))
   (setq Lst (cdr Lst))
   (setq L2 (cdr L2))
   (setq Lst (mapcar '(lambda (x) (- x)) Lst))
   (setq L2 (mapcar '(lambda (x) (list (car x)(caddr x) (cadr x))) L2))
   (cond ((= (vla-get-closed obj) :vlax-true) (setq a (- a))))
   (setq Lst (append Lst (list a)))
   (setq L2 (append L2 (list (list (car b)(caddr b) (cadr b)))))
   (setq n -1)
   (foreach x Lst (vla-SetBulge Obj (setq n (1+ n)) x))
   (mapcar '(lambda (x) (apply 'vla-setwidth (cons obj x))) L2)
)
  )
  (vla-Update Obj)
)
;;分析弧
;;不封闭(-0.629332 1.07928 -0.4596 0.0 1.20521)(0.0 0.4596 -1.07928 0.629332 1.20521)
;;封闭(0.0 0.323551 -0.647648 1.95661 0.107475)(-1.95661 0.647648 -0.323551 0.0 -0.107475)
(defun C:W1 (/ E L1 LST M N OBJ OBJNAME PNTLST TMPLST X)
  (setq e (car (entsel)))
  (setq Obj (vlax-ename->vla-object e))
  (setq       ObjName       (vlax-get Obj 'ObjectName)
      TmpLst       (vlax-get Obj 'Coordinates)
  )
  (setq n (/ (length TmpLst) 2))
  (setq n (length PntLst))
  (repeat (setq m n)
(setq x (vla-GetBulge Obj (setq m (1- m))))
(setq L1 (cons x L1))
  )
  (command "reverse" e "")
  (repeat n
(setq x (vla-GetBulge Obj (setq n (1- n))))
(setq Lst (cons x Lst))
  )
  (princ L1)
  (princ Lst)
)

;;分析线宽
;;不封闭((0 9.0 0.0) (1 8.0 5.0) (2 2.0 9.0) (3 9.0 9.0))((0 9.0 2.0) (1 5.0 8.0) (2 0.0 9.0) (3 9.0 9.0))
;;封闭((0 9.0 8.0) (1 8.0 8.0) (2 8.0 2.0) (3 5.0 0.0))((0 2.0 8.0) (1 8.0 8.0) (2 8.0 9.0) (3 0.0 5.0))
(defun C:W2 (/ E EW L1 L2 M N OBJ OBJNAME SW TMPLST)
  (setq e (car (entsel)))
  (setq Obj (vlax-ename->vla-object e))
  (setq       ObjName       (vlax-get Obj 'ObjectName)
      TmpLst       (vlax-get Obj 'Coordinates)
  )
  (setq n (/ (length TmpLst) 2))
  (repeat (setq m n)
(vla-GetWidth Obj (setq m (1- m)) 'sw 'ew)
(setq L1 (cons (list m sw ew) L1))
  )
  (command "reverse" e "")
  (repeat n
(vla-GetWidth Obj (setq n (1- n)) 'sw 'ew)
(setq L2 (cons (list n sw ew) L2))
  )
  (princ L1)
  (princ L2)
)

kele99kele · 发表于 2015-7-14 15:25

跟老大学习，回帖查看

laiz3000 · 发表于 2015-7-14 20:12

这个实用

wlmq · 发表于 2015-7-24 15:38

以前遇到过有凸凹反不过来

xman00 · 发表于 2015-7-31 21:08

很高深的学问啊。

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

[源码] 多段线反向

评分

点评