[engngr]

Команды, помогающие в подготовке исходных материалов к оцифровке (выполнении, например, в civil т.н. цмр из геоподосновы (топографического плана) или плана организации рельефа (вертикальной планировки) объекта из приходящих от смежников или заказчика плоских чертежей):

ee - меняет высоту (по z) отрезка или полилинии на заданную в комстроке величину, далее присваивает выбираемым отрезкам или полилиниям значения больше (меньше) на заданный в комстроке шаг

ee2 - меняет высоту отрезка или полилинии на 'высоту' по выбранному образцу из полилинии или отрезка

ee3 - меняет высоты выбранных отрезков или полилиний последовательно, начиная с "базовой" и далее с заданным шагом; выбор объектов - секущей линией

ee4 - строит трехмерную полилинию по заданным курсором точкам, отетка z каждой точки определяется выбором текста с отметкой (не мтекста, разделитель дробной части - точка, значение имеет только первая последовательность, представляющая сособой высотную отметку)

Код:

[Выделить все]

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;
;;;;;;ee - меняет высоту (по z) отрезка или полилинии на заданную в комстроке величину, 
;;;;;;далее присваивает выбираемым отрезкам или полилиниям значения больше (меньше) на заданный в комстроке шаг
;;;;;;
;;;;;;ee2 - меняет высоту отрезка или полилинии на 'высоту' по выбранному образцу из полилинии или отрезка
;;;;;;
;;;;;;ee3 - меняет высоты выбранных отрезков или полилиний последовательно, 
;;;;;;начиная с "базовой" и далее с заданным шагом; выбор объектов - секущей линией
;;;;;;
;;;;;;ee4 - строит трехмерную полилинию по заданным курсором точкам, 
;;;;;;отетка z каждой точки определяется выбором текста с отметкой 
;;;;;;(не мтекста, разделитель дробной части - точка, значение имеет только первая последовательность, представляющая сособой высотную отметку)
;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun c:ee (/ belStr belGet incGet incStr oldecho objsel obj10 obj11)
  (vl-load-com)

  ;;;;;;;;;;;;startblock 
  (defun *error*(msg)
     (setvar "CMDECHO" oldecho)
	 (command "_.ucs" "_p")
	 (princ)
   ); end of *error*
  (setq oldecho (getvar "cmdecho"))
  (setvar "cmdecho" 0)

  ;; Undo Begin
  (command "_.Undo" "_BE")
    
  (command "_.ucs" "_w")
  ;;;;;;;;;;;;startblock

;;;;;;base level or elevation
 (if (= bel nil) (setq bel 0))
  (setq belStr (rtos bel))
  (setq belGet (getreal (strcat "Input base level <" belStr ">: ")))
  (if (= belGet nil) (setq belGet bel) (setq bel belGet))

;;;;;;;increment(decrement)
(if (= inc nil) (setq inc 0.1))
(setq incStr (rtos inc))
(setq incGet (getreal (strcat "Input level change <" incStr ">: ")))
(if (= incGet nil) (setq incGet inc) (setq inc incGet))
 

(setq oldecho (getvar "cmdecho") )
  (setvar "cmdecho" 0)
  
  (while
    (setq objsel (car (entsel "\nSelect horizontal: ")))
       
    (if (= "LWPOLYLINE" (cdr (assoc 0 (entget objsel)))) (vla-put-elevation (vlax-ename->vla-object objsel) bel))

    (if (= "LINE" (cdr (assoc 0 (entget objsel))))
    (progn 
       (setq obj10 (assoc 10 (entget objsel)))
       (setq obj11 (assoc 11 (entget objsel)))

       (entmod
          (subst (reverse (cons bel (cdr (reverse obj10)))) obj10
          (subst (reverse (cons bel (cdr (reverse obj11)))) obj11
          (entget objsel)
          );subst
          );subst  
       );entmod
     );progn
     );if

    (vla-put-Color (vlax-ename->vla-object objsel) acGreen)
    (princ (strcat "\nlvl was set to: " (rtos bel)))
    (setq bel (+ bel inc))
  ); end while

  
  (command "_.Undo" "_E")
  (command "_.ucs" "_p")
  (setvar "cmdecho" oldecho)
  
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:ee2 (/ oldecho objsor objtar obj10 obj11)
(vl-load-com)

;;;;;;;;;;;;  
  (defun *error*(msg)
     (setvar "CMDECHO" oldecho)
	 (command "_.ucs" "_p")
	 (princ)
   ); end of *error*

  (setq oldecho (getvar "cmdecho"))
  (setvar "cmdecho" 0)

  ;; Undo Begin
  (command "_.Undo" "_BE")
    
  (command "_.ucs" "_w")
;;;;;;;;;;;;
  (while ;while1
  (setq objsor (car (entsel "\nSelect source horizontal: ")))

    (if (= "LWPOLYLINE" (cdr (assoc 0 (entget objsor)))) (setq bel (cdr (assoc 38 (entget objsor))))) ;;;;;; NOT CDR
    (if (= "LINE" (cdr (assoc 0 (entget objsor)))) (setq bel (nth 3 (assoc 10 (entget objsor)))));;;;;; NOT CDR
  
  (while ;;;;;;;;;;;while2
    
  (setq objtar (car (entsel "\nSelect target horizontal: ")))

    (if (= "LWPOLYLINE" (cdr (assoc 0 (entget objtar)))) (vla-put-elevation (vlax-ename->vla-object objtar) bel))

    (if (= "LINE" (cdr (assoc 0 (entget objtar))))
    (progn 
       (setq obj10 (assoc 10 (entget objtar)))
       (setq obj11 (assoc 11 (entget objtar)))

       (entmod
          (subst (reverse (cons bel (cdr (reverse obj10)))) obj10
          (subst (reverse (cons bel (cdr (reverse obj11)))) obj11
          (entget objtar)
          );subst
          );subst  
       );entmod
     );progn
     );if

    (vla-put-Color (vlax-ename->vla-object objtar) acGreen)
    (princ (strcat "\nlvl was set to: " (rtos bel)))
   
  ); end while2
  ); end while1

  ;; Undo End
  (command "_.Undo" "_E")
  (command "_.ucs" "_p")
  (setvar "cmdecho" oldecho)
  
)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:ee3 (/ pp pp1 ss i oo obj10 obj11 em lp)

  (setq em (getvar "cmdecho") )
  (setvar "cmdecho" 0)

  
;;;;;;;;;;;;;;;;;;;;; setting base elevation
  (if (= bel nil) (setq bel 0))
    (setq belStr (rtos bel))
    (setq belGet (getreal (strcat "Input base level <" belStr ">: ")))
  (if (= belGet nil) (setq belGet bel) (setq bel belGet))
  

;;;;;;;;;;;;;;;;;;;;; setting increment(decrement)
(if (= inc nil) (setq inc 0.1))
(setq incStr (rtos inc))
(setq incGet (getreal (strcat "Input level change <" incStr ">: ")))
(if (= incGet nil) (setq incGet inc) (setq inc incGet))



  (setq pp nil)

  (while 
    (if (/= lp nil) (setq pp1 (getpoint lp)) (setq pp1 (getpoint)))
    (setq lp pp1)
    (setq pp (append pp (list pp1)))
    ;(if (= pp nil) (setq pp (list (getpoint))) (setq pp (append pp (list(getpoint)))))
  );while

  (setq ss (ssget "_F" pp))



  
  (setq i 0)
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  modifing
  (repeat (sslength ss)
    (setq oo (entget (ssname ss i)))

        (if (= "LWPOLYLINE" (cdr (assoc 0 oo))) (vla-put-elevation (vlax-ename->vla-object (ssname ss i)) bel))

    (if (= "LINE" (cdr (assoc 0 oo)))
    (progn 
       (setq obj10 (assoc 10 oo))
       (setq obj11 (assoc 11 oo))

       (entmod
          (subst (reverse (cons bel (cdr (reverse obj10)))) obj10
          (subst (reverse (cons bel (cdr (reverse obj11)))) obj11
          (entget (ssname ss i))
          );subst
          );subst  
       );entmod
     );progn
     );if

    (vla-put-Color (vlax-ename->vla-object (ssname ss i)) acGreen)
    (setq bel (+ bel inc))
    (setq i (1+ i))
    );repeat
  (princ (strcat "\nLast given lvl was: " (rtos (- bel inc))))

  (setvar "cmdecho" em)
  (princ)
	   
      
  );defun
  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:ee4
  (/ ptsl lvl pt lpt myerr olderr lvlobj)
  
(defun myerr ( msg )
        (setq *error* olderr)
        (princ "\n*error* inside of test program.")  
        (princ)
    )

    (setq olderr *error*
          *error* myerr
	  ptsl nil
	  pt nil
	  lpt nil)

  

  (vl-load-com)

;;; making point list for further 3dpoly
  (while;while1 
    (if (= lpt nil) (setq pt (getpoint  "\ninput point: ")) (setq pt (getpoint  lpt "\ninput point: ")))

    (setq lpt pt
	  lvl nil)

    (while;while2
      (= lvl nil)
      (setq lvl (entsel "\nselect object with elevation text: "))
      (if (and (/= lvl nil)
               (= (cdr (assoc 0 (entget (car lvl)))) "TEXT")
	       (= (type (atof (cdr (assoc 1 (entget (car lvl)))))) 'REAL)
	       (/= (atof (cdr (assoc 1 (entget (car lvl))))) 0.0 )
	  );and

	()
	(progn (princ "\ntry again")
               (setq lvl nil)
	)
	;(setq lvl lvl)
    );if
      );while2
    (setq lvlobj (car lvl)) 
    (vla-put-Color (vlax-ename->vla-object lvlobj) acGreen)
    (setq pt (reverse
	       (append
		 (list (atof (cdr (assoc 1 (entget (car lvl)))))
		 
	         );list
                 (cdr (reverse pt))
		 );append
              )
     );setq pt

    (setq ptsl (append ptsl (list pt))
	  )
     
   );while1


(cdx-Add3DPoly ptsl)


  (setq *error* olderr)
	  
  (princ)
);defun


;;;;;;;;;https://forum.dwg.ru/showpost.php?p=700346&postcount=7
(setq *cdl_actvdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))
(defun cdx-Add3DPoly (lst / templst)
;;; ????????? 3? ????????
;;;(cdx-Add3DPoly (list '(0 0) '(100 200) '(300 300 300)))
  (vla-Add3DPoly
	(vla-get-Block (vla-get-ActiveLayout *cdl_actvdoc*))
	(vlax-safearray-fill
	  (vlax-make-safearray
		vlax-vbDouble
		(vl-list* 0 (1- (length (setq templst
		  (apply 'append (mapcar (function
			(lambda (x)
			  (cond
				((= 2 (length x)) (list (car x) (cadr x) 0.0))
				(T x))))
			  lst)))))))
	  templst
	)
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

[staricby]

спасибо! это просто великолепная прога!