Topic: Looking for app/routine

[nobody]

Anyone know of a routine that will set the ends of arcs, lines, polylines to elevations of points at their same location? Hoping to save the effort of having to write it

[lamarn]

What about LM entopo?

[ribarm]

Untested...

Code: [Select]

(defun c:curves2elevbypts ( / *error* *adoc* ssc ssp i p pl k c sp ep spn epn en e )

  (vl-load-com)

  (defun *error* ( m )
    (vla-endundomark *adoc*)
    (if m
      (prompt m)
    )
    (princ)
  )

  (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
  (prompt "\nSelect curves...")
  (setq ssc (ssget "_:L" '((0 . "*POLYLINE,SPLINE,ELLIPSE,ARC,LINE"))))
  (while (or (not ssc) (not (vl-every '(lambda ( x / minp maxp ) (progn (vla-getboundingbox (vlax-ename->vla-object x) 'minp 'maxp) (equal (caddr (safearray-value minp)) (caddr (safearray-value maxp)) 1e-6))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssc))))))
    (prompt "\nEmpty sel.set or some of selected entities not in plane parallel to WCS... Retry selecting curves...")
    (setq ssc (ssget "_:L" '((0 . "*POLYLINE,SPLINE,ELLIPSE,ARC,LINE"))))
  )
  (prompt "\nSelect points in 3D as projections of ends of curves to reposition curves according to them...")
  (setq ssp (ssget '((0 . "POINT"))))
  (while (not ssp)
    (prompt "\nEmpty sel.set... Retry selecting points...")
    (setq ssp (ssget '((0 . "POINT"))))
  )
  (repeat (setq i (sslength ssp))
    (setq p (cdr (assoc 10 (entget (ssname ssp (setq i (1- i)))))))
    (setq pl (cons p pl))
  )
  (setq k 0)
  (repeat (setq i (sslength ssc))
    (setq c (ssname ssc (setq i (1- i))))
    (setq sp (vlax-curve-getstartpoint c))
    (setq ep (vlax-curve-getendpoint c))
    (setq spn (car (vl-member-if '(lambda ( x ) (equal (mapcar '+ '(0.0 0.0) sp) (mapcar '+ '(0.0 0.0) x) 1e-6)) pl)))
    (setq epn (car (vl-member-if '(lambda ( x ) (equal (mapcar '+ '(0.0 0.0) ep) (mapcar '+ '(0.0 0.0) x) 1e-6)) pl)))
    (cond
      ( (and spn epn)
        (setq en (/ (+ (caddr spn) (caddr epn)) 2.0))
        (setq e (/ (+ (caddr sp) (caddr ep)) 2.0))
        (vla-move (vlax-ename->vla-object c) (vlax-3d-point (list 0.0 0.0 e)) (vlax-3d-point (list 0.0 0.0 en)))
      )
      ( (and spn (not epn))
        (setq en (caddr spn))
        (setq e (caddr sp))
        (vla-move (vlax-ename->vla-object c) (vlax-3d-point (list 0.0 0.0 e)) (vlax-3d-point (list 0.0 0.0 en)))
      )
      ( (and epn (not spn))
        (setq en (caddr epn))
        (setq e (caddr ep))
        (vla-move (vlax-ename->vla-object c) (vlax-3d-point (list 0.0 0.0 e)) (vlax-3d-point (list 0.0 0.0 en)))
      )
      ( t
        (setq k (1+ k))
      )
    )
  )
  (prompt "\nTotal : ")(princ k)(prompt " curves that don't have matching points and haven't been moved...")
  (*error* nil)
)

HTH, M.R.

[nobody]

Thank you!