Программы

Рейтинг:  0 / 5

Звезда не активнаЗвезда не активнаЗвезда не активнаЗвезда не активнаЗвезда не активна
 

Метки на чертеже - AutoLISP код


;;; Вставка замечаний для Н.Контроля 
;;; Создано RIES.PRO для ООО "Промстройпроект"
;;; Распространяется бесплатно
;;; Skype RIES.PRO
;;; www.RIES.PRO
(progn
(vl-load-com)				; подгрузка vl функций
(alert (strcat 
					"Программа для установки меток к которым нужно будет вернуться загружена\n"
					"На чертеже должен присутствовать блок метки: marker_04_06_16  на слое Pr_Marker\n\n"
					"Поставить метку marker_put\n"
					"Просмотреть все метки и переход на метку marker_get\n"
			)
	)																	; сообщение
	(setq lde_0 "marker_04_06_16") 										; блок метки
	(defun C:marker_put () 												; вставка метки
		(setq lay (getvar "CLAYER")) 									; запомнить текущий слой	
		(setq q (getvar "ATTREQ"))										; запомнить текущиее значение запроса значений атрибутов при вставке блока	
		(command "_.layer" "_Marker" "_C" "1" "Pr_Marker")				; создать слой	
		(command)														; отказ от выбора	
		(setq point (getpoint "Точка куда вставить метку?")) 			; точка вставки листа			
		(setvar "CLAYER" "Pr_Marker")									; переключаемся на слой
		(setvar "ATTREQ" 0)												; убрать запрос значений атрибутов
		(command "_.-insert" lde_0 point "1" "1" "0") 					; вставлен
		(terpri)(terpri)(terpri)(terpri)(terpri)(terpri)(terpri)			; пустая строка
		(setq zna_E1 (getstring " Заметка о метке: "))					; информация о метке	
		(terpri)														; пустая строка
		(setq a (entlast))												; вызов последнего элемента т.е. вставленного блока	
		(setq blk (vlax-ename->vla-object  a)) 							; превратили в vla объект	
		(setq a1 (entnext a))											; положили в а1 список атрибутов	
			(setq b1 (cdr (assoc '2 (entget a1)))) 						; взяли название атрибута
			(if (equal b1 "question")									; проверяем атрибуты перед вставкой
				(progn 
					(setq b1 (subst (cons 1 zna_E1) (assoc '1 (entget a1)) (entget a1) ))			; записали
					(entmod b1)	(entupd a1)															; перерисовали
				)
			)
		(setvar "ATTREQ" q)												; вернуть запрос значений атрибутов (если он был)
		(setvar "CLAYER" lay)											; вернуть слой
	) 																	; конец C:marker_put
	(defun C:marker_get ()
		(setq 
			nab nil
			b nil
			i 0
		)
		(setq nab (ssget "_X" (list (cons 8 "Pr_Marker") (cons 0 "INSERT"))))	; создать наборbr>
		(setq b (sslength nab)) 													; всего в наборе
		(alert (strcat "Найдено меток: " (itoa b) "   "))						; сообщение о найденом
	(if (> b 0)
		(progn 
			(repeat b
				(setq a (ssname nab i))											; взяли первый блок из набора
				(setq a_E (entnext a)) 											; взяли свойства блока
				(setq a_E1 (cdr(assoc '2(entget a_E)))) 							; название атрибута 
				(if (equal a_E1 "question")
					(progn 
						(setq zna (cdr(assoc '1 (entget a_E))))					; взяли значение атрибута 
						(setq a_E (entnext a_E))
						(setq a_E1 (cdr (assoc '2 (entget a_E))))
						(setq zna1 (cdr(assoc '1 (entget a_E))))					; взяли значение атрибута 
					)
					(progn 
						(alert "Найденый блок не является меткой!")
					)
				)	
				(princ (strcat "Метка " (rtos i) " | question: " zna)) 			; сообщение
				(terpri)
				(princ (strcat "        |" " answer:   " zna1))					; сообщение
				(terpri)
				(setq i (+ i 1))
			)
			(textscr)  															; вызвали командную строку
		)
		(progn
			(alert "Метки не найдены!")
		)
	)
		(setq i (getint " Перейти к метке: "))											; запрос номера метки
		(setq a (ssname nab i))															; взяли первый блок из набора
		(setq blk (entnext a))															; взяли нформацию блока
		(setq pt_blk (cdr(assoc '10(entget blk))))										; переписали правильно координаты блока
		(setq pt1 (list (+ (nth 0 pt_blk) 50) (+ (nth 1 pt_blk) 50) (nth 2 pt_blk)))		; точка 1 для зуммирования
		(setq pt2 (list (- (nth 0 pt_blk) 50) (- (nth 1 pt_blk) 50) (nth 2 pt_blk)))		; точка 2 для зуммирования
		(command "_zoom" pt1 pt2) 														; переход на метку
			
	)
)


Тэги: AutoLISP

Добавить комментарий

Администратор оставляет за собой право удалять любой комментарий без разъяснения.


Защитный код
Обновить