[编程交流] 将二维多段线转换为三维fr

;; entmake a 3dpoly      by AlanJT                                            ;
(defun _pline (lst)
   (if (and (> (length lst) 1)
            (entmakex '((0 . "POLYLINE") (10 0. 0. 0.) (70 . ))
            (foreach x lst (entmakex (list '(0 . "VERTEX") (cons 10 x) '(70 . 32))))
       )
     (cdr (assoc 330 (entget (entmakex '((0 . "SEQEND"))))))
   )
 )

(defun c:chgpoly ( )
 (setq en1 (car (entsel"\nSelect Polyline: "))
 pl (listpol en1)
 ss (ssget "_F" pl '((0 . "INSERT")))
       lst nil        
 )
 (repeat (setq i (sslength ss))     
    (setq blk (ssname ss (setq i (1- i)))  
          enb (entget blk)
   ipt (cdr (assoc 10 enb))
    en (entnext blk)
   enl (entget en)
    )
    (while (= (cdr (assoc 0 enl)) "ATTRIB")
       (if (= (cdr (assoc 2 enl)) "ELEV")
   (progn
      (setq  p (list (car ipt) (cadr ipt) (atof (cdr (assoc 1 enl))))
           lst (cons p lst)
      )
   )  
)         
       (setq en (entnext en) enl (entget en))                                                 
    )
 )
 (if (vlax-curve-IsClosed en1) (setq lst (cons (last lst) lst)))
 (_pline lst)
 (entdel en1)
)
   
         
  
;; entmake a 3dpoly      by Alan J Thompson                                   ;
(defun _pline (lst)
   (if (and (> (length lst) 1)
            (entmakex '((0 . "POLYLINE") (10 0. 0. 0.) (70 . ))
            (foreach x lst (entmakex (list '(0 . "VERTEX") (cons 10 x) '(70 . 32))))
       )
     (cdr (assoc 330 (entget (entmakex '((0 . "SEQEND"))))))
   )
 )
;; List vertices of a polyline  Original code by Gile Chanteau                ;
(defun listpol (en / i p l)  
 (setq        i (if (vlax-curve-IsClosed en)
              (vlax-curve-getEndParam en)
     (+ (vlax-curve-getEndParam en) 1)
  )
 )        
 (while (setq p (vlax-curve-getPointAtParam en (setq i (1- i))))
     (setq l (cons p l))
 )
)

(defun c:demo1 (/ attlst e lst obj par poly pt s s1 z)
 (if (setq s (ssget "_+.:E:S" '((0 . "LWPOLYLINE"))))
   (progn
     (vl-cmdf "_.DRAWORDER"  (ssname s 0) "" "_B"
       "_.zoom" "_O" (ssname s 0) ""
       "_.-layer" "_M" "3DPoly_Test" "_C" "3" "3DPoly_Test" "" ""
     );; vl-cmdf
     (setq poly (vlax-ename->vla-object (ssname s 0))
    e         (fix (vlax-curve-getEndParam poly))
    par         0
    lst         nil
     );; setq
     (while (/= par (1+ e))
(setq pt (vlax-curve-getPointAtParam poly par))
(if (setq s1 (ssget pt '((0 . "INSERT") (2 . "Point") (66 . 1))))
  (progn
    (setq obj         (vlax-ename->vla-object (ssname s1 0))
          attlst (vlax-invoke obj 'GetAttributes)
    );; setq
    (foreach att attlst
      (if (= (vla-get-TagString att) "ELEV")
        (setq z          (atof (vla-get-TextString att))
              pt  (list (car pt) (cadr pt) z)
              lst (cons pt lst)
        );; setq
      );; if
    );; foreach
  );; progn
);; if
(setq par (1+ par))
     );; while
     (if lst
(progn
  (setq lst (reverse lst))
  (entmake (list '(0 . "POLYLINE")
                 (if (vlax-curve-IsClosed poly)
                   '(70 . 9)
                   '(70 . 
                 );; if
           );; list
  );; entmake
  (foreach x lst
    (entmake (list '(0 . "VERTEX")
                   '(70 . 32)
                   (cons 10 x)
             );; list
    );; entmake
  );; foreach
  (entmake '((0 . "SEQEND")))
);; progn
     );; if
     (vl-cmdf "_.zoom" "_P")
   );; progn
 );; if
 (princ)
);; demo1

(defun c:demo2 (/ attlst e obj par poly pt s s1 )
 (if (setq s (ssget "_+.:E:S" '((0 . "POLYLINE") (-4 . "&") (70 . )))
   (progn
     (vl-cmdf "_.DRAWORDER" (ssname s 0) "" "_B"
       "_.zoom" "_O" (ssname s 0) ""
     );; vl-cmdf
     (setq poly (vlax-ename->vla-object (ssname s 0))
    e         (fix (vlax-curve-getEndParam poly))
    par         0
     );; setq
     (while (/= par (1+ e))
(setq pt (vlax-curve-getPointAtParam poly par))
(if (setq s1 (ssget pt '((0 . "INSERT") (2 . "Point") (66 . 1))))
  (progn
    (setq obj         (vlax-ename->vla-object (ssname s1 0))
          attlst (vlax-invoke obj 'GetAttributes)
    );; setq
    (foreach att attlst
      (if (= (vla-get-TagString att) "ELEV")
        (vla-put-TextString att (rtos (caddr pt) 2 2))
      );; if
    );; foreach
  );; progn
);; if
(setq par (1+ par))
     );; while
     (vl-cmdf "_.zoom" "_P")
   );; progn
 );; if
 (princ)
);; demo2

;;CADALYST 09/03 AutoLISP Solutions
;;; PLINE-3D-2D.LSP - a program to convert
;;; 3D polylines to 2D
;;; Program by Tony Hotchkiss
(defun pline-3d-2d ()
 (vl-load-com)
 (setq        *thisdrawing* (vla-get-activedocument
                (vlax-get-acad-object)
              ) ;_ end of vla-get-activedocument
*modelspace*  (vla-get-ModelSpace *thisdrawing*)
 ) ;_ end of setq
 (setq        3d-pl-list
 (get-3D-pline)
 ) ;_ end of setq
 (if 3d-pl-list
   (progn
     (setq vert-array-list (make-list 3d-pl-list))
     (setq n (- 1))
     (repeat (length vert-array-list)
(setq vert-array (nth (setq n (1+ n)) vert-array-list))
(setq lyr (vlax-get-property (nth n 3d-pl-list) 'Layer))
(setq obj (vla-AddPolyline *modelspace* vert-array))
(vlax-put-property obj 'Layer lyr)
     ) ;_ end of repeat
     (foreach obj 3d-pl-list (vla-delete obj))
   ) ;_ end of progn
 ) ;_ end of if
) ;_ end of pline-3d-2d
(defun get-3D-pline ()
 (setq        pl3dobj-list nil
obj             nil
3d             "AcDb3dPolyline"
 ) ;_ end of setq
 (setq selsets (vla-get-selectionsets *thisdrawing*))
 (setq ss1 (vlax-make-variant "ss1"))
 (if (= (vla-get-count selsets) 0)
   (setq ssobj (vla-add selsets ss1))
 ) ;_ end of if
 (vla-clear ssobj)
 (setq Filterdata (vlax-make-variant "POLYLINE"))
 (setq no-ent 1)
 (while no-ent
   (vla-Selectonscreen ssobj)
   (if        (> (vla-get-count ssobj) 0)
     (progn
(setq no-ent nil)
(setq i (- 1))
(repeat        (vla-get-count ssobj)
  (setq
    obj        (vla-item ssobj
                  (vlax-make-variant (setq i (1+ i)))
        ) ;_ end of vla-item
  ) ;_ end of setq
  (cond
    ((= (vlax-get-property obj "ObjectName") 3d)
     (setq pl3dobj-list
            (append pl3dobj-list (list obj))
     ) ;_ end of setq
    )
  ) ;_ end-of cond
) ;_ end of repeat
     ) ;_ end of progn
     (prompt "\nNo entities selected, try again.")
   ) ;_ end of if
   (if        (and (= nil no-ent) (= nil pl3dobj-list))
     (progn
(setq no-ent 1)
(prompt "\nNo 3D-polylines selected.")
(quit)
     ) ;_ end of progn
   ) ;_ end of if
 ) ;_ end of while  
 (vla-delete (vla-item selsets 0))
 pl3dobj-list
) ;_ end of get-3D-pline
(defun get-3D-pline-old ()
 (setq no-ent 1)
 (setq        filter '((-4 . "<AND")
         (0 . "POLYLINE")
         (70 . 
         (-4 . "AND>")
        )
 ) ;_ end of setq
 (while no-ent
   (setq ss               (ssget filter)
  k               (- 1)
  pl3dobj-list nil
  obj               nil
  3d               "AcDb3dPolyline"
   ) ;_ end-of setq
   (if        ss
     (progn
(setq no-ent nil)
(repeat        (sslength ss)
  (setq        ent (ssname ss (setq k (1+ k)))
        obj (vlax-ename->vla-object ent)
  ) ;_ end-of setq
  (cond
    ((= (vlax-get-property obj "ObjectName") 3d)
     (setq pl3dobj-list
            (append pl3dobj-list (list obj))
     ) ;_ end of setq
    )
  ) ;_ end-of cond
) ;_ end-of repeat
     ) ;_ end-of progn
     (prompt "\nNo 3D-polylines selected, try again.")
   ) ;_ end-of if
 ) ;_ end-of while
 pl3dobj-list
) ;_ end of get-3D-pline-old
(defun make-list (p-list)
 (setq        i (- 1)
vlist nil
calist nil
 ) ;_ end of setq
 (repeat (length p-list)
   (setq obj         (nth (setq i (1+ i)) p-list)
  coords (vlax-get-property obj "coordinates")
  ca         (vlax-variant-value coords)
   ) ;_ end-of setq
   (setq calist (append calist (list ca)))
 ) ;_ end-of repeat
) ;_ end-of make-list
(defun c:pl32 ()
 (pline-3d-2d)
 (princ)
) ;_ end of pl32
(prompt "Enter PL32 to start: ")

(defun c:demo3 (/ E ELV LST PAR POLY PT PT0 LST S X ZDIR)
 (vl-load-com)
 (if (setq s (ssget "_+.:E:S" '((0 . "POLYLINE") )))
   (progn
     (setq poly (vlax-ename->vla-object (ssname s 0))
    e         (fix (vlax-curve-getEndParam poly))
    par         0
    lst         nil
     );; setq
     (while (/= par (1+ e))
(setq pt  (vlax-curve-getPointAtParam poly par)
      pt0 (list (car pt) (cadr pt) 0.0)
      lst (cons pt0 lst)
);; setq
(setq par (1+ par))
     );; while
     (if lst
(progn
  (setq        lst  (reverse lst)
        zdir (trans '(0 0 1) 1 0 T)
        elv  (caddr (trans (car lst) 1 zdir))
  );; setq
  (entmake
    (append
      (list (cons 0 "LWPOLYLINE")
            (cons 100 "AcDbEntity")
           ;(cons 8 "YourLayer")
           ;(cons 62 "YourColor")
            (cons 100 "AcDbPolyline")
            (cons 90 (length lst))
            (if        (vlax-curve-IsClosed poly)
              '(70 . 1)
              '(70 . 0)
            );; if
            (cons 38 elv)
           ;(cons 43 "YourWidth)
            (cons 210 zdir)
      );; list
      (mapcar '(lambda (x) (cons 10 (trans x 1 zdir))) lst)
    );; append
  );; entmake
);; progn
     );; if
   );; progn
 );; if
 (princ)
);; demo3