修改三角网问题

杜流浪人

类似于cass中“重组三角形”这个命令，
我自己参照一组三角形进行编写可以了，再修改其他的三角形就失败了
请高手给与指正，谢谢

;;; 46.2 [功能] pline,lwpline点坐标表  By 无痕
;;; 示例(vxs (car (entsel))),返回三维点坐标
(defun vxs (e / i v lst)
  (setq i -1)
  (while (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
    (setq lst (cons v lst))
  )
  (reverse lst)
)
(VL-LOAD-COM)
(defun c:tt ()                               ; (setq lst '())
  (setq ssa (ssget '((0 . "POLYLINE"))))
  (setq i 0
        lst '()
  )
  (repeat (sslength ssa)
    (setq en (ssname ssa i)
          ptb (vxs en)                       ;   (entdel en)
          ptb (plf-Lst-DelSame1 ptb)
          pzx (append
                pzx
                (list ptb)
              )
          i (1+ i)
    )                                       ;          (setq lst (PLF-Lst-Append
                                       ; (car pzx) (cadr pzx)))
    (setq lst pzx)
  )
  (setq list1 (list (last (cadr lst)) (car (car lst)) (cadr (car lst))
                    (last (cadr lst))
              )
  )
  (setq list2 (list (last (cadr lst)) (cadr (car lst)) (caddr (car lst))
                    (last (cadr lst))
              )
  )
  (mk3DPOLYLINE list1)
  (mk3DPOLYLINE list2)
  (entdel ssa)
  (princ)
)
;;; end defun
(defun plf-Lst-DelSame1 (l)
  (if l
    (cons (car l) (plf-Lst-DelSame1 (vl-remove (car l) l)))
  )
)
;;; 三维点表绘制3D多段线
(defun mk3DPOLYLINE (ptlst)
  (entmake (list '(0 . "POLYLINE") '(100 . "AcDbEntity") '(100 . "AcDb3dPolyline")
                 '(66 . 1) '(70 . 8)
           )
  )
  (foreach pt ptlst
    (entmake (list '(0 . "vertex") (cons 10 pt) '(70 . 32)))
  )
  (entmake '((0 . "seqend")))
)

330774521lhq

啥也不说了，感谢楼主分享哇！

杜流浪人

330774521lhq 发表于 2017-2-9 11:21

感谢啥啊    不成功    等待高手改造呢

hanyaxinshou

继续努力，直到问题解决。

st788796

用 xdrxapi 给你个思路，一次选择连个相邻的三角形，对角线交换

2. 
   
3. (defun c:tt (/ ss e1 e2 pts pts1 pts2 p1 p2 i1 i2)
   
4.   (while (and (setq ss (ssget '((0 . "polyline"))))
   
5.            (= (sslength ss) 2)
   
6.       )
   
7.     (progn
   
8.       (setq e1         (ssname ss 0)
   
9.             e2         (ssname ss 1)
   
10.             pts1 (xdrx_getpropertyvalue e1 "stretchpoint")
    
11.             pts2 (xdrx_getpropertyvalue e2 "stretchpoint")
    
12.             pts         (vl-remove-if
    
13.                    (function (lambda (x) (not (member x pts2))))
    
14.                    pts1
    
15.                  )
    
16.             p1         (car
    
17.                    (vl-remove-if (function (lambda (x) (member x pts2))) pts1)
    
18.                  )
    
19.             p2         (car
    
20.                    (vl-remove-if (function (lambda (x) (member x pts1))) pts2)
    
21.                  )
    
22.       )
    
23.       (setq i1 (vl-position (car pts) pts1)
    
24.             i2 (vl-position (cadr pts) pts2)
    
25.       )
    
26.       (xdrx_entity_movestretchpoint
    
27.         e1
    
28.         (mapcar '- p2 (car pts))
    
29.         i1
    
30.       )
    
31.       (xdrx_entity_movestretchpoint
    
32.         e2
    
33.         (mapcar '- p1 (cadr pts))
    
34.         i2
    
35.       )
    
36.     )
    
37.   )
    
38.   (princ)
    
39. )
    

<br /> (defun c:tt (/ ss e1 e2 pts pts1 pts2 p1 p2 i1 i2)<br />   (while (and (setq ss (ssget '((0 . "polyline"))))<br />            (= (sslength ss) 2)<br />       )<br />     (progn<br />       (setq e1         (ssname ss 0)<br />             e2         (ssname ss 1)<br />             pts1 (xdrx_getpropertyvalue e1 "stretchpoint")<br />             pts2 (xdrx_getpropertyvalue e2 "stretchpoint")<br />             pts         (vl-remove-if<br />                    (function (lambda (x) (not (member x pts2))))<br />                    pts1<br />                  )<br />             p1         (car<br />                    (vl-remove-if (function (lambda (x) (member x pts2))) pts1)<br />                  )<br />             p2         (car<br />                    (vl-remove-if (function (lambda (x) (member x pts1))) pts2)<br />                  )<br />       )<br />       (setq i1 (vl-position (car pts) pts1)<br />             i2 (vl-position (cadr pts) pts2)<br />       )<br />       (xdrx_entity_movestretchpoint<br />         e1<br />         (mapcar '- p2 (car pts))<br />         i1<br />       )<br />       (xdrx_entity_movestretchpoint<br />         e2<br />         (mapcar '- p1 (cadr pts))<br />         i2<br />       )<br />     )<br />   )<br />   (princ)<br /> )<br />

杜流浪人

st788796 发表于 2017-2-10 22:15

谢谢你            

aeo

三角网不是正方形等特殊图形，是唯一的，为什么要互换呢？

杜流浪人

aeo 发表于 2017-2-12 23:07

三角网在生成时候  有时候是不符合实际地形的   需要修改一下   对边转换