lisp2arx
Visual Programming for AutoLisp Mathématiques en programmation Lisp.. doc2cpp,doc2lsp, sld2lsp, bmp2dcl, free__GifCcapture for all-CAD'platforms..
Lista Forumurilor Pe Tematici
lisp2arx | Reguli | Inregistrare | Login

POZE LISP2ARX

Nu sunteti logat.
Nou pe simpatie:
Nebunyka pe Simpatie
Femeie
21 ani
Bacau
cauta Barbat
21 - 52 ani
lisp2arx / Listof AutoLisp.100 / vla-AutoLisp2K- Spline To Polylone Moderat de zauchan
Autor
Mesaj Pagini: 1
zauchan
Moderator

Inregistrat: acum 13 ani
Postari: 180

;;CADALYST 12/03 AutoLISP Solutions  SPLINE-TO-PLINE.LSP
;;(c) 2003 Tony Hotchkiss

Code:

(defun spline-to-pline (/ i)
  (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 spline-list (acge_splineent2d))
  (setq i (- 1))
  (if spline-list
    (progn
      (setq msg "\nNumber of segments <100>: ")
      (initget 6)
      (setq num (getint msg))
      (if (or (= num 100) (= num nil))
    (setq num 100)
      ) ;_ end of if
      (repeat (length spline-list)
    (setq splobj (nth (setq i (1+ i)) spline-list))
    (acge_nurbcurve splobj num)
      ) ;_ end of repeat
    ) ;_ end of progn
  ) ;_ end of if
) ;_ end of spline-to-pline

(defun acge_splineent2d (/ spl-list obj spline no-ent i)
  (setq    spl-list nil
    obj     nil
    spline     "AcDbSpline"
    selsets     (vla-get-selectionsets *thisdrawing*)
    ss1     (vlax-make-variant "ss1")
  ) ;_ end of setq
  (if (= (vla-get-count selsets) 0)
    (setq ssobj (vla-add selsets ss1))
  ) ;_ end of if
  (vla-clear ssobj)
  (setq no-ent 1)
  (while no-ent
    (prompt "\nSelect splines: ")
    (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") spline)
         (setq spl-list
            (append spl-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 spl-list))
      (progn
    (setq no-ent 1)
    (prompt "\nNo splines selected.")
    (quit)
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of while  
  (vla-delete (vla-item selsets 0))
  spl-list
) ;_ end of acge_splineent2d

(defun acge_nurbcurve (splobj n / i)
  (setq    tag "convert -spline"
        point-list   nil
    2Dpoint-list nil
    z-list         nil
    spl-lyr         (vlax-get-property splobj 'Layer)
    startSpline  (vlax-curve-getStartParam splobj)
    endSpline    (vlax-curve-getEndParam splobj)
    i         (- 1)
  ) ;_ end of setq
  (repeat (+ n 1)
    (setq i (1+ i))
    (setq p (vlax-curve-getPointAtParam
          splobj
          (* i
         (/ (- endspline startspline) n)
          ) ;_ end of *
        ) ;_ end of vlax-curve-getPointAtParam
    ) ;_ end of setq
    (setq 2Dp           (list (car p) (cadr p))
      2Dpoint-list (append 2Dpoint-list 2Dp)
      point-list   (append point-list p)
      z           (caddr p)
      z-list       (append z-list (list z))
    ) ;_ end of setq
  ) ;_ end of repeat
  (setq summ (apply '+ z-list))
  (setq    arraySpace
     (vlax-make-safearray
       vlax-vbdouble ; element type
       (cons 0
         (- (length point-list) 1)
       ) ; array dimension
     ) ;_ end of vlax-make-safearray
  ) ;_ end of setq
  (setq vert-array (vlax-safearray-fill arraySpace point-list))
  (vlax-make-variant vert-array)
  (if (and (= :vlax-true (vlax-get-property splobj 'IsPLanar))
       (= summ 0.0)
      ) ;_ end of and
    (setq plobj    (acge_polyline_add
          2Dpoint-list
          vla-AddLightweightPolyline
        ) ;_ end of acge_polyline_add
    ) ;_ end of setq
    (setq plobj    (acge_polyline_add
          point-list
          vla-Add3DPoly
        ) ;_ end of acge_polyline_add
    ) ;_ end of setq
  ) ;_ end of if
  (vlax-put-property plobj 'Layer spl-lyr)
  (vla-delete splobj)
  (vlax-release-object splobj)
) ;_ end of acge_nurbcurve

(defun acge_polyline_add (pt-list poly-func)
  (setq    arraySpace
     (vlax-make-safearray
       vlax-vbdouble
       (cons 0
         (- (length pt-list) 1)
       ) ; array dimension
     ) ;_ end of vlax-make-safearray
  ) ;_ end of setq
  (setq    vertex-array
     (vlax-safearray-fill arraySpace pt-list)
  ) ;_ end of setq
  (vlax-make-variant vertex-array)
  (setq    plobj (poly-func
        *modelspace*
        vertex-array
          ) ;_ end of poly-func
  ) ;_ end of setq
   (vla-put-color plobj  (atoi (getvar "CECOLOR")))
  ;;(vla-put-colorindex plobj 2)
  
) ;_ end of acge_polyline_add

(defun c:s2p ()
  (spline-to-pline)
  (princ)
) ;_ end of c:s2p

(prompt
  "SPLINE-TO-PLINE by Tony Hotchkiss. Enter S2P to start"
) ;_ end of prompt



_______________________________________
psw: cea de la wjndowsXP gigabyte..

pus acum 4 ani
   
Pagini: 1  

Mergi la