Schöck
dwg.ru forum rss xml
| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Готовые программы > LISP. Команды для перевода 2d геоподосновы и вертикальной планировки в 3d

LISP. Команды для перевода 2d геоподосновы и вертикальной планировки в 3d

Версия для печати
 
Ответ
Опции темы Поиск в этой теме
Непрочитано 09.07.2018, 19:46 #1
LISP. Команды для перевода 2d геоподосновы и вертикальной планировки в 3d
engngr
 
сети
 
Московия*
Регистрация: 03.11.2008
Сообщений: 4,037
Отправить сообщение для engngr с помощью Skype™

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
	)
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Вложения
Тип файла: lsp ee.lsp (8.6 Кб, 5 просмотров)

Просмотров: 178
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Готовые программы > LISP. Команды для перевода 2d геоподосновы и вертикальной планировки в 3d

КОМПОЗИТНЫЕ ПАНЕЛИ ДЛЯ ФАСАДА
Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск

Быстрый переход

Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Как удалить прошлые разрезы, как сделать новый 2d, 3d разрез (Autocad Architecture 2012) nickolay198 Вертикальные решения на базе AutoCAD 12 20.02.2013 12:02
аксонометрия (2D и 3D) и спецификация (автоматизация) alldmc AutoCAD 3 28.10.2012 13:44
Перевод 3D в 2D Unic AutoCAD 6 04.08.2011 11:17
Как сделать из 3D сборки 2D чертёж. Удалив 3D модель. Toystar AutoCAD 15 22.03.2011 19:00
Lisp Как поставить диаметр отверстия на 3D solidе P4s8x LISP 4 06.11.2008 19:31

|| Главная || Каталог САПР || Тендеры || Публикации || Объявления || Биржа труда || Download || Галерея ||
|| Библиотека || Кунсткамера || Каталог предприятий || Контакты || Файлообменник || Блоги ||