[编程交流] 复制最近的高程

(vl-load-com)
(defun c:qq    (/ elevations sss)
 (if (ssget '((0 . "*POLYLINE")))
   (progn
     (vlax-for    x (vla-get-activeselectionset
           (vla-get-activedocument (vlax-get-acad-object))
         )
   (setq elevations (cons (vla-get-elevation x) elevations))
     )
(prompt "\n2nd Selection")
(setq sss (ssget "_:L"))
(command"_.CHANGE" sss "" "_P" "_E" (rtos (last elevations))
       
   
     )
    )
 )
 (princ)
)

(defun c:fixelevation ( / dis dst elv ent enx idx lst src tmp vts )
   (if (and (setq src (LM:ssget "\nSelect polylines with elevation: " '(((0 . "LWPOLYLINE")))))
            (setq dst (LM:ssget "\nSelect polylines to modify: "      '("_:L" ((0 . "LWPOLYLINE")))))
       )
       (progn
           (repeat (setq idx (sslength src))
               (setq ent (ssname src (setq idx (1- idx)))
                     lst (cons (cons ent (assoc 38 (entget ent))) lst)
               )
           )
           (repeat (setq idx (sslength dst))
               (setq enx (entget (ssname dst (setq idx (1- idx))))
                     vts (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) enx))
                     dis (getmindistance (caar lst) vts)
                     elv (cdar lst)
               )
               (foreach itm (cdr lst)
                   (if (< (setq tmp (getmindistance (car itm) vts)) dis)
                       (setq elv (cdr itm)
                             dis tmp
                       )
                   )
               )
               (entmod (subst elv (assoc 38 enx) enx))
           )
       )
   )
   (princ)
)
(defun getmindistance ( ent lst / dis tmp )
   (setq dis 1e308)
   (foreach vtx lst
       (if (< (setq tmp (distance vtx (vlax-curve-getclosestpointto ent vtx))) dis)
           (setq dis tmp)
       )
   )
   dis
)
;; ssget  -  Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments
(defun LM:ssget ( msg arg / sel )
   (princ msg)
   (setvar 'nomutt 1)
   (setq sel (vl-catch-all-apply 'ssget arg))
   (setvar 'nomutt 0)
   (if (not (vl-catch-all-error-p sel)) sel)
)
(vl-load-com) (princ)