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

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Неправильная нумерация элементов в наборе на полилинии.

Неправильная нумерация элементов в наборе на полилинии.

Ответ
Поиск в этой теме
Непрочитано 02.02.2019, 12:08 #1
Неправильная нумерация элементов в наборе на полилинии.
AlexZh
 
Регистрация: 23.09.2015
Сообщений: 143

Здравствуйте, форумчане!

AutoCad 2016.

Столкнулся с такой проблемой. Разными программами неправильно нумеруются блоки из набора на полилинии. То есть, выполняется не по порядку начертания полилинии, а по какому-то другому алгоритму. Причем на рабочем компьютере этими же программами нумеруются нормально. А на домашнем неправильно.

Одна из программ из набора AndySoft. Другая - моя

Код:
[Выделить все]
 (defun c:number	(/ *error* adress ar briz i number obj sc ss)
  (load "selpoly")
;;; -------------------------------------------------------------------------
  ;; Get Attribute Value  -  Lee Mac
  ;; Returns the value held by the specified tag within the supplied
  ;; block, if
  ;; present.
  ;; blk - [vla] VLA Block Reference Object
  ;; tag - [str] Attribute TagString
  ;; Returns: [str] Attribute value, else nil if tag is not found.
  (defun lm:vl-getattributevalue (blk tag)
    (setq tag (strcase tag))
    (vl-some '(lambda (att)
		(if (= tag (strcase (vla-get-tagstring att)))
		  (vla-get-textstring att)
		) ;_ конец if
	      ) ;_ конец lambda
	     (vlax-invoke blk 'getattributes)
    ) ;_ конец vl-some
  ) ;_ конец defun
  ;; Set Attribute Value  -  Lee Mac
  ;; Sets the value of the first attribute with the given tag found
  ;; within the block, if
  ;; present.
  ;; blk - [vla] VLA Block Reference Object
  ;; tag - [str] Attribute TagString
  ;; val - [str] Attribute Value
  ;; Returns: [str] Attribute value if successful, else nil.
  (defun lm:vl-setattributevalue (blk tag val)
    (setq tag (strcase tag))
    (vl-some '(lambda (att)
		(if (= tag (strcase (vla-get-tagstring att)))
		  (progn (vla-put-textstring att val) val)
		) ;_ конец if
	      ) ;_ конец lambda
	     (vlax-invoke blk 'getattributes)
    ) ;_ конец vl-some
  ) ;_ конец defun
  ;; Get Visibility Parameter Name  -  Lee Mac
  ;; Returns the name of the Visibility Parameter of a Dynamic Block
  ;; (if
  ;; present)
  ;; blk - [vla] VLA Dynamic Block Reference object
  ;; Returns: [str] Name of Visibility Parameter, else nil
  (defun lm:getvisibilityparametername (blk / vis)
    (if	(and (vlax-property-available-p blk 'effectivename)
	     (setq blk (vla-item (vla-get-blocks (vla-get-document blk))
				 (vla-get-effectivename blk)
		       ) ;_ конец vla-item
	     ) ;_ конец setq
	     (= :vlax-true (vla-get-isdynamicblock blk))
	     (= :vlax-true (vla-get-hasextensiondictionary blk))
	     (setq
	       vis (vl-some
		     '(lambda (pair)
			(if (and (= 360 (car pair))
				 (= "BLOCKVISIBILITYPARAMETER"
				    (cdr (assoc 0 (entget (cdr pair))))
				 ) ;_ конец =
			    ) ;_ конец and
			  (cdr pair)
			) ;_ конец if
		      ) ;_ конец lambda
		     (dictsearch
		       (vlax-vla-object->ename
			 (vla-getextensiondictionary blk)
		       ) ;_ конец vlax-vla-object->ename
		       "ACAD_ENHANCEDBLOCK"
		     ) ;_ конец dictsearch
		   ) ;_ конец vl-some
	     ) ;_ конец setq
	) ;_ конец and
      (cdr (assoc 301 (entget vis)))
    ) ;_ конец if
  ) ;_ конец defun
  (defun _value_to_str (value /)
;;; переводит значение в строковое состояние и ставит ноль перед
;;; числом
    (if	(= 'str (type value))
      value
      (if (< value 10)
	(setq value (strcat "0"
			    (if	(= 'str (type value))
			      value
			      (itoa value)
			    ) ;_ конец if
		    ) ;_ конец strcat
	) ;_ конец setq
	(setq value (if	(= 'str (type value))
		      value
		      (itoa value)
		    ) ;_ конец if
	) ;_ конец setq
      ) ;_ конец if
    ) ;_ конец if
  ) ;_ конец defun
  ;; Effective Block Name  -  Lee Mac
  ;; obj - [vla] VLA Block Reference object
  (defun lm:effectivename (obj)
    (vlax-get-property
      obj
      (if (vlax-property-available-p obj 'effectivename)
	'effectivename
	'name
      ) ;_ конец if
    ) ;_ конец vlax-get-property
  ) ;_ конец defun
  (defun donumbertostring (number /)
;;; переводит значение в строковое состояние и ставит ноль перед
;;; числом
;;; вызов - (DonumberToString 3), (DonumberToString 10),
;;; (DonumberToString "03")
    (load "StringIsNumber")
    (if	(stringisnumber number)
      (if (< number 10)
	(setq number (strcat "0"
			     (if (stringisnumber number)
			       number
			       (itoa number)
			     ) ;_ конец if
		     ) ;_ конец strcat
	) ;_ конец setq
	(setq number (if (stringisnumber number)
		       number
		       (itoa number)
		     ) ;_ конец if
	) ;_ конец setq
      ) ;_ конец if
    ) ;_ конец if
  ) ;_ конец defun
  (defun numbering (device / number)
    (setq number
	   (progn (initget "01")
		  (cond	((getint (strcat "\nВведите "
					 device
					 ", с которого начинаем <01>: "
				 ) ;_ конец strcat
			 )    ; _
			) ;_ конец not
			(t (setq number 1)) ;_ конец if
		  ) ;_ конец cond
	   ) ;_ конец progn
    ) ;_ конец cond
    (1- number)
  ) ;_ конец defun
  (defun adress+ (adress index/) (donumbertostring (+ index adress)))
;;; Пример использования (Adress+ 1 1) - "02"
  ;;-----------------------------------------------------------------
  (setq	number (getstring "Введите номер прибора: ")
	adress (numbering "адрес") ;_ конец progn
	briz   (numbering "БРИЗ") ;_ конец progn
	ar     (numbering "адресного расширителя") ;_ конец progn
	sc     (numbering "релейного блока") ;_ конец progn
	i      0
  ) ;_ конец cond
  (while (setq
	   ss (selpoly (list (cons 0 "INSERT") (cons 8 "1Z*") (cons 66 1))
			      ; _
			      ; конец
			      ; list
	      ) ;_ конец selpoly
	 ) ;_ конец selpoly
    (if	(> (sslength ss) 0)
      (progn (sssetfirst nil ss)
	     (setq
	       msg (strcat "\nВыбрано "
			   (itoa (sslength ss))
			   " объектов. Уберите лишнее или [Выход] <Выход>"
		   ) ;_ конец strcat
	     ) ;_ конец setq
	     (initget "Выход")
	     (while (setq obj (car (entsel msg) ; _
			      ) ;_ конец car
		    ) ;_ конец setq
	       (if (ssmemb obj ss)
		 (setq ss (ssdel obj ss))
	       ) ;_ конец if
	       (sssetfirst nil ss)
	       (setq msg
		      (strcat "\nВыбрано "
			      (itoa (sslength ss))
			      " объектов. Уберите лишнее или [Выход] <Выход>"
		      ) ;_ конец strcat
	       ) ;_ конец setq
	     ) ;_ конец while
      ) ;_ конец progn
    ) ;_ конец if
    (setq i 0) ;_ конец cond
    ;; -----------------------------------------------------------------
    (while (< i (sslength ss))
      (setq obj (vlax-ename->vla-object (ssname ss i))) ;_ конец setq
      ;; -----------------------------------------------------------------
      (cond
	((wcmatch (lm:effectivename obj) "*BRIZ")
	 (if (/= i 0)
	   (lm:vl-setattributevalue
	     obj
	     "ОБОЗНАЧЕНИЕ"
	     (strcat number
		     "BRIZ"
		     (_value_to_str (setq briz (1+ briz)))
	     )		      ; _
			      ; конец
			      ; strcat
	   ) ;_ конец lm:vl-setattributevalue
	 ) ;_ конец if
	)
	((wcmatch (lm:effectivename obj) "*SC")
	 (lm:vl-setattributevalue
	   obj
	   "ОБОЗНАЧЕНИЕ"
	   (strcat number "SC" (_value_to_str (setq sc (1+ sc))))
	 ) ;_ конец lm:vl-setattributevalue
	 (if (wcmatch (lm:vl-getattributevalue obj "ЗНАЧЕНИЕ") "СП2*")
	   (lm:vl-setattributevalue
	     obj
	     "АДРЕС"
	     (strcat (_value_to_str (1+ adress))
		     "-"
		     (_value_to_str (setq adress (+ 2 adress)))
	     ) ;_ конец if
	   ) ;_ конец lm:vl-setattributevalue
	   (if
	     (wcmatch (lm:vl-getattributevalue obj "ЗНАЧЕНИЕ") "СП4*")
	      (lm:vl-setattributevalue
		obj
		"АДРЕС"
		(strcat	(_value_to_str (1+ adress))
			"-"
			(_value_to_str (setq adress (+ 5 adress)))
		) ;_ конец if
	      ) ;_ конец lm:vl-setattributevalue
	   ) ;_ конец if
	 ) ;_ конец if
	)		      ; _
	;; -----------------------------------------------------------------
	((wcmatch (lm:effectivename obj) "*AR")
	 (lm:vl-setattributevalue
	   obj
	   "ОБОЗНАЧЕНИЕ"
	   (strcat number "AR" (_value_to_str (setq ar (1+ ar))))
			      ; _ конец
	 ) ;_ конец lm:vl-setattributevalue
	 (if (wcmatch (lm:vl-getattributevalue obj "ЗНАЧЕНИЕ") "АР-2")
	   (lm:vl-setattributevalue
	     obj
	     "АДРЕС"
	     (strcat (_value_to_str (1+ adress))
		     "-"
		     (_value_to_str (setq adress (+ 2 adress)))
	     ) ;_ конец if
	   ) ;_ конец lm:vl-setattributevalue
	   (if
	     (wcmatch (lm:vl-getattributevalue obj "ЗНАЧЕНИЕ") "АР-8")
	      (lm:vl-setattributevalue
		obj
		"АДРЕС"
		(strcat	(_value_to_str (1+ adress))
			"-"
			(_value_to_str (setq adress (+ 8 adress)))
		) ;_ конец if
	      ) ;_ конец lm:vl-setattributevalue
	      (lm:vl-setattributevalue
		obj
		"АДРЕС"
		(_value_to_str (setq adress (+ 1 adress)))
	      ) ;_ конец lm:vl-setattributevalue
	   ) ;_ конец if
	 ) ;_ конец if
	)
	((wcmatch (lm:effectivename obj) "*BTK")
	 ;; если блок - камера
	 (lm:vl-setattributevalue
	   obj
	   "ОБОЗНАЧЕНИЕ"
	   (strcat number
		   "BTK"
		   (_value_to_str (setq adress (+ 1 adress)))
	   )		      ; _ конец
	 ) ;_ конец lm:vl-setattributevalue
	)
	((wcmatch (lm:effectivename obj) "*BTH")
	 ;; если блок - камера
	 (lm:vl-setattributevalue
	   obj
	   "ОБОЗНАЧЕНИЕ"
	   (strcat number
		   "BTH"
		   (_value_to_str (setq adress (+ 1 adress)))
	   )		      ; _ конец
	 ) ;_ конец lm:vl-setattributevalue
	)
	((wcmatch (lm:effectivename obj) "*BTM")
	 (lm:vl-setattributevalue
	   obj
	   "ОБОЗНАЧЕНИЕ"
	   (strcat number
		   "BTM"
		   (_value_to_str (setq adress (+ 1 adress)))
	   )		      ; _ конец
	 )		      ; _
	) ;_ конец lm:vl-setattributevalue
      ) ;_ конец cond
      (vla-update obj)
      (setq i (1+ i))
    ) ;_ конец while
    (sssetfirst ss nil)
    (princ (strcat (_value_to_str adress) " адресов"))
  ) ;_ конец while
) ;_ конец if
;|«Visual LISP© Format Options»
(72 2 30 2 T "конец " 72 9 1 1 0 T nil T T)
;*** НЕ добавляйте текст под комментариями! ***|;
__________________
Проекты СС
Просмотров: 1599
 
Непрочитано 02.02.2019, 14:51
#2
Семёныч


 
Регистрация: 08.12.2018
Сообщений: 101


Цитата:
Сообщение от AlexZh Посмотреть сообщение
Разными программами неправильно нумеруются блоки из набора на полилинии.
А где пример расположения блоков на полилинии? Самим, что ли, сочинять?
Семёныч вне форума  
 
Автор темы   Непрочитано 21.05.2019, 17:53
#3
AlexZh


 
Регистрация: 23.09.2015
Сообщений: 143


Возрожу тему. Бьюсь уже долго. Не могу понять причину неверной нумерации.
Код:
[Выделить все]
  (defun c:number	(/ *error* adress ar briz i number obj sc ss)
;;; -------------------------------------------------------------------------
  ;; Get Attribute Value  -  Lee Mac
  ;; Returns the value held by the specified tag within the supplied
  ;; block, if
  ;; present.
  ;; blk - [vla] VLA Block Reference Object
  ;; tag - [str] Attribute TagString
  ;; Returns: [str] Attribute value, else nil if tag is not found.
  (defun lm:vl-getattributevalue (blk tag)
    (setq tag (strcase tag))
    (vl-some '(lambda (att)
		(if (= tag (strcase (vla-get-tagstring att)))
		  (vla-get-textstring att)
		) ;_ конец if
	      ) ;_ конец lambda
	     (vlax-invoke blk 'getattributes)
    ) ;_ конец vl-some
  ) ;_ конец defun
  ;; Set Attribute Value  -  Lee Mac
  ;; Sets the value of the first attribute with the given tag found
  ;; within the block, if
  ;; present.
  ;; blk - [vla] VLA Block Reference Object
  ;; tag - [str] Attribute TagString
  ;; val - [str] Attribute Value
  ;; Returns: [str] Attribute value if successful, else nil.
  (defun lm:vl-setattributevalue (blk tag val)
    (setq tag (strcase tag))
    (vl-some '(lambda (att)
		(if (= tag (strcase (vla-get-tagstring att)))
		  (progn (vla-put-textstring att val) val)
		) ;_ конец if
	      ) ;_ конец lambda
	     (vlax-invoke blk 'getattributes)
    ) ;_ конец vl-some
  ) ;_ конец defun
  ;; Get Visibility Parameter Name  -  Lee Mac
  ;; Returns the name of the Visibility Parameter of a Dynamic Block
  ;; (if
  ;; present)
  ;; blk - [vla] VLA Dynamic Block Reference object
  ;; Returns: [str] Name of Visibility Parameter, else nil
  (defun lm:getvisibilityparametername (blk / vis)
    (if	(and (vlax-property-available-p blk 'effectivename)
	     (setq blk (vla-item (vla-get-blocks (vla-get-document blk))
				 (vla-get-effectivename blk)
		       ) ;_ конец vla-item
	     ) ;_ конец setq
	     (= :vlax-true (vla-get-isdynamicblock blk))
	     (= :vlax-true (vla-get-hasextensiondictionary blk))
	     (setq
	       vis (vl-some
		     '(lambda (pair)
			(if (and (= 360 (car pair))
				 (= "BLOCKVISIBILITYPARAMETER"
				    (cdr (assoc 0 (entget (cdr pair))))
				 ) ;_ конец =
			    ) ;_ конец and
			  (cdr pair)
			) ;_ конец if
		      ) ;_ конец lambda
		     (dictsearch
		       (vlax-vla-object->ename
			 (vla-getextensiondictionary blk)
		       ) ;_ конец vlax-vla-object->ename
		       "ACAD_ENHANCEDBLOCK"
		     ) ;_ конец dictsearch
		   ) ;_ конец vl-some
	     ) ;_ конец setq
	) ;_ конец and
      (cdr (assoc 301 (entget vis)))
    ) ;_ конец if
  ) ;_ конец defun
   ;;; -------------------------------------------------------------------------
  (defun _value_to_str (value /)
;;; переводит значение в строковое состояние и ставит ноль перед
;;; числом
    (if	(= 'str (type value))
      value
      (if (< value 10)
	(setq value (strcat "0"
			    (if	(= 'str (type value))
			      value
			      (itoa value)
			    ) ;_ конец if
		    ) ;_ конец strcat
	) ;_ конец setq
	(setq value (if	(= 'str (type value))
		      value
		      (itoa value)
		    ) ;_ конец if
	) ;_ конец setq
      ) ;_ конец if
    ) ;_ конец if
  ) ;_ конец defun
  ;; Effective Block Name  -  Lee Mac
  ;; obj - [vla] VLA Block Reference object
  (defun lm:effectivename (obj)
    (vlax-get-property
      obj
      (if (vlax-property-available-p obj 'effectivename)
	'effectivename
	'name
      ) ;_ конец if
    ) ;_ конец vlax-get-property
  ) ;_ конец defun
;;; -------------------------------------------------------------------------
  (defun donumbertostring (number /)
;;; переводит значение в строковое состояние и ставит ноль перед
;;; числом
;;; вызов - (DonumberToString 3), (DonumberToString 10),
;;; (DonumberToString "03")
    (load "StringIsNumber")
    (if	(stringisnumber number)
      (if (< number 10)
	(setq number (strcat "0"
			     (if (stringisnumber number)
			       number
			       (itoa number)
			     ) ;_ конец if
		     ) ;_ конец strcat
	) ;_ конец setq
	(setq number (if (stringisnumber number)
		       number
		       (itoa number)
		     ) ;_ конец if
	) ;_ конец setq
      ) ;_ конец if
    ) ;_ конец if
  ) ;_ конец defun
  (defun adress+ (adress index/) (donumbertostring (+ index adress)))
;;; Пример использования (Adress+ 1 1) - "02"
  ;;-----------------------------------------------------------------
  (setq	number (getstring "Введите номер прибора: ")
	adress 0 ;_ конец progn
	briz   -1 ;_ конец progn
	ar     -1 ;_ конец progn
	sc     -1 ;_ конец progn
	i      0
  ) ;_ конец cond
   (setq polyline (chooseobject
			    "LWPOLYLINE"
			    "1Z_APS_*,*Cable*,1Z*"
			    "Выход"
			    "\nВыберите линию 
			    или [Выход] <Выход>:"
			  ) ;_ конец _1z_choice_obj
	   )
  (setq
	   ss (selpoly (list (cons 0 "INSERT") (cons 8 "1Z*") (cons 66 1))
			      ; _
			      ; конец
			      ; list
	      ) ;_ конец selpoly
	 ) ;_ конец selpoly
    (if	(> (sslength ss) 0)
      (progn (sssetfirst nil ss)
	     (setq
	       msg (strcat "\nВыбрано "
			   (itoa (sslength ss))
			   " объектов. Уберите лишнее или [Выход] <Выход>"
		   ) ;_ конец strcat
	     ) ;_ конец setq
	     (initget "Выход")
	     (while (setq obj (car (entsel msg) ; _
			      ) ;_ конец car
		    ) ;_ конец setq
	       (if (ssmemb obj ss)
		 (setq ss (ssdel obj ss))
	       ) ;_ конец if
	       (sssetfirst nil ss)
	       (setq msg
		      (strcat "\nВыбрано "
			      (itoa (sslength ss))
			      " объектов. Уберите лишнее или [Выход] <Выход>"
		      ) ;_ конец strcat
	       ) ;_ конец setq
	     ) ;_ конец while
      ) ;_ конец progn
    ) ;_ конец if
    (setq i 0) ;_ конец cond
    ;; -----------------------------------------------------------------
    (while (< i (sslength ss))
      (setq obj (vlax-ename->vla-object (ssname ss i))) ;_ конец setq
      ;; -----------------------------------------------------------------
      (cond
	((wcmatch (lm:effectivename obj) "*BRIZ")
	 (if (/= i 0)
	   (lm:vl-setattributevalue
	     obj
	     "ОБОЗНАЧЕНИЕ"
	     (strcat number
		     "BRIZ"
		     (_value_to_str (setq briz (1+ briz)))
	     )		      ; _
			      ; конец
			      ; strcat
	   ) ;_ конец lm:vl-setattributevalue
	 ) ;_ конец if
	)
	((wcmatch (lm:effectivename obj) "*SC")
	 (lm:vl-setattributevalue
	   obj
	   "ОБОЗНАЧЕНИЕ"
	   (strcat number "SC" (_value_to_str (setq sc (1+ sc))))
	 ) ;_ конец lm:vl-setattributevalue
	 (if (wcmatch (lm:vl-getattributevalue obj "ЗНАЧЕНИЕ") "СП2*")
	   (lm:vl-setattributevalue
	     obj
	     "АДРЕС"
	     (strcat (_value_to_str (1+ adress))
		     "-"
		     (_value_to_str (setq adress (+ 2 adress)))
	     ) ;_ конец if
	   ) ;_ конец lm:vl-setattributevalue
	   (if
	     (wcmatch (lm:vl-getattributevalue obj "ЗНАЧЕНИЕ") "СП4*")
	      (lm:vl-setattributevalue
		obj
		"АДРЕС"
		(strcat	(_value_to_str (1+ adress))
			"-"
			(_value_to_str (setq adress (+ 5 adress)))
		) ;_ конец if
	      ) ;_ конец lm:vl-setattributevalue
	   ) ;_ конец if
	 ) ;_ конец if
	)		      ; _
	;; -----------------------------------------------------------------
	((wcmatch (lm:effectivename obj) "*AR")
	 (lm:vl-setattributevalue
	   obj
	   "ОБОЗНАЧЕНИЕ"
	   (strcat number "AR" (_value_to_str (setq ar (1+ ar))))
			      ; _ конец
	 ) ;_ конец lm:vl-setattributevalue
	 (if (wcmatch (lm:vl-getattributevalue obj "ЗНАЧЕНИЕ") "АР-2")
	   (lm:vl-setattributevalue
	     obj
	     "АДРЕС"
	     (strcat (_value_to_str (1+ adress))
		     "-"
		     (_value_to_str (setq adress (+ 2 adress)))
	     ) ;_ конец if
	   ) ;_ конец lm:vl-setattributevalue
	   (if
	     (wcmatch (lm:vl-getattributevalue obj "ЗНАЧЕНИЕ") "АР-8")
	      (lm:vl-setattributevalue
		obj
		"АДРЕС"
		(strcat	(_value_to_str (1+ adress))
			"-"
			(_value_to_str (setq adress (+ 8 adress)))
		) ;_ конец if
	      ) ;_ конец lm:vl-setattributevalue
	      (lm:vl-setattributevalue
		obj
		"АДРЕС"
		(_value_to_str (setq adress (+ 1 adress)))
	      ) ;_ конец lm:vl-setattributevalue
	   ) ;_ конец if
	 ) ;_ конец if
	)
	((wcmatch (lm:effectivename obj) "*BTK")
	 ;; если блок - камера
	 (lm:vl-setattributevalue
	   obj
	   "ОБОЗНАЧЕНИЕ"
	   (strcat number
		   "BTK"
		   (_value_to_str (setq adress (+ 1 adress)))
	   )		      ; _ конец
	 ) ;_ конец lm:vl-setattributevalue
	)
	((wcmatch (lm:effectivename obj) "*BTH")
	 ;; если блок - камера
	 (lm:vl-setattributevalue
	   obj
	   "ОБОЗНАЧЕНИЕ"
	   (strcat number
		   "BTH"
		   (_value_to_str (setq adress (+ 1 adress)))
	   )		      ; _ конец
	 ) ;_ конец lm:vl-setattributevalue
	)
	((wcmatch (lm:effectivename obj) "*BTM")
	 (lm:vl-setattributevalue
	   obj
	   "ОБОЗНАЧЕНИЕ"
	   (strcat number
		   "BTM"
		   (_value_to_str (setq adress (+ 1 adress)))
	   )		      ; _ конец
	 )		      ; _
	) ;_ конец lm:vl-setattributevalue
      ) ;_ конец cond
      (vla-update obj)
      (setq i (1+ i))
    ) ;_ конец while
    (sssetfirst ss nil)
    (princ (strcat (_value_to_str adress) " адресов"))
) ;_ конец if
;|«Visual LISP© Format Options»
(72 2 30 2 T "конец " 72 9 1 1 0 T nil T T)
;*** НЕ добавляйте текст под комментариями! ***|;
(defun chooseobject (nameentity		layer
		     initstring		promptstring
		     /			returnedentity
		     listoffeaturesofentity
		    )
		    ;|	ВОЗВРАЩАЕТ  - имя объекта (ename) при удачном выборе или nil
		nameEntity - тип примитива ("LINE", "INSERT", "*LINE" и т.п.)
		layer - маска слоя для wcmatch (Слой1* Слой1,Слой2,#Lay* и т.п.)
		initstring - строка для initget (ограничение для последуещего ввода данных)
		promptstring - строка приглашения
		В случае выбора объекта точка выбора сохраняется в переменной LASTPOINT
Пример использования:
(ChooseObj "INSERT" "1Z_APS_EQUIPMENT*" "Выход" "\nВыберите приемное устройство или [Выход] <Выход>:")
ERRNO - Отображает номер соответствующего кода ошибки, когда вызов функции AutoLISP приводит к ошибке, выявленной AutoCAD.
|;
  (while
    (progn
      (setvar 'errno 0)
      (initget initstring)
      (setq returnedentity (entsel promptstring)) ;_ конец setq
      (cond ((= 7 (getvar 'errno))
	     (princ "\nНичего не выбрано! Пробуй снова.")
	    )
	    ((null returnedentity) nil)
	    ((and (= nameentity
		     (cdr (assoc 0
				 (setq listoffeaturesofentity
					(entget (car returnedentity))
				 ) ;_ конец setq
			  ) ;_ конец assoc
		     ) ;_ конец cdr
		  ) ;_ конец =
		  (wcmatch (cdr (assoc 8 listoffeaturesofentity)) layer)
		  (setq	returnedobject
			 (cdr (assoc 330 listoffeaturesofentity))
		  ) ;_ конец setq
	     ) ;_ конец and
	     nil
	    ) ;_ конец and
	    ((princ "\nПопробуй еще раз!"))
      ) ;_ конец cond
    ) ;_ конец progn
  ) ;_ конец while
  (if (and returnedentity (listp returnedentity)) ;_Что-то выбрали
    (progn (setvar "LASTPOINT" (cadr returnedentity))
			      ; _сохраняем точку
			      ; выбора в
			      ; LASTPOINT
	   (car returnedentity)
    ) ;_ конец progn
  ) ;_ конец if
)
;;; -------------------------------------------------------------------------
(defun c:selpoly (/ ss1 x )
;;; Выделение объектов, пересекаемых полилинией
    (selpoly nil)
    (princ)
  ) ;_ конец defun
;;; -------------------------------------------------------------------------
  (defun c:bselpoly ()
;;; Выделение блоков, пересекаемых полилинией
    (selpoly (list (cons 0 "INSERT")))
    (princ)
  ) ;_ конец defun
;;; -------------------------------------------------------------------------
  (defun block-get-name	(blkobj)
    (cond ((and	(vlax-property-available-p blkobj 'isdynamicblock)
		(= (vla-get-isdynamicblock blkobj) :vlax-true)
	   ) ;_ end of and
	   (vla-get-effectivename blkobj)
	  )
	  (t (vla-get-name blkobj))
    ) ;_ end of cond
  ) ;_ конец defun
  ;| ! *******************************************************************
;; !                  _IsPtInView
;; ! *******************************************************************
;; ! Проверяет находится ли точка в видовом экране
;; ! Auguments: 'pt'  - Точка для анализа в МСК!!!
;; ! Return   : T или nil если 'pt' в видовом экране или нет
;; ! *******************************************************************|;
  (defun _get-viewctr-size (/ vctr y_len ssz x_pix y_pix x_len)
    (setq vctr	(getvar "VIEWCTR")
	  y_len	(getvar "VIEWSIZE")
	  ssz	(getvar "SCREENSIZE")
	  x_pix	(car ssz)
	  y_pix	(cadr ssz)
	  x_len	(* (/ x_pix y_pix) y_len)
    ) ;_ конец setq
    (list (mapcar '- vctr (list (* 0.5 x_len) (* 0.5 y_len)))
	  (mapcar '+ vctr (list (* 0.5 x_len) (* 0.5 y_len)))
    ) ;_ конец list
  ) ;_ конец defun
  (defun _isptinview (pt / lc uc)
    (setq pt (trans pt 0 1))
    (setq lc (_get-viewctr-size)
	  uc (cadr lc)
	  lc (car lc)
    ) ;_ конец setq
    (if	(and (> (car pt) (car lc))
	     (< (car pt) (car uc))
	     (> (cadr pt) (cadr lc))
	     (< (cadr pt) (cadr uc))
	) ;_ конец and
      t
      nil
    ) ;_ конец if
  ) ;_ конец defun
  ;| ! ***************************************************************************
;; !           _pt_extents
;; ! ***************************************************************************
;; ! Function : Возвращает границы MIN, MAX X,Y,Z списка точек
;; ! Argument : 'vlist' - Список точек
;; ! Returns  : Список точек (ЛевНижн ПравВерхн)
;; ! ***************************************************************************|;
  (defun _pt_extents (vlist / tmp)
    (setq tmp (apply 'mapcar (cons 'list vlist)))
    (list (mapcar '(lambda (x) (apply 'min x)) tmp)
	  (mapcar '(lambda (x) (apply 'max x)) tmp)
    ) ;_ конец list
  ) ;_defun
  ;; !                             _Zoom2Lst
  ;; ! **********************************************************
  ;; ! Function : Zoom границ списка точек
  ;; ! Arguments: 'vlist' - Список точек в МСК!!!!
  ;; ! Зуммирует экран, чтобы все точки были видны
  ;; ! Returns  : t - было зуммирование nil - нет
  ;; ! **********************************************************
  (defun _zoom2lst (vlist / pts)
    (setq pts (_pt_extents (mip:zzero vlist)))
    (if	(not (and (_isptinview (car pts)) (_isptinview (cadr pts))))
      (progn (vla-zoomwindow
	       (vlax-get-acad-object)
	       (vlax-3d-point (car pts))
	       (vlax-3d-point (cadr pts))
	     ) ;_ конец vla-ZoomWindow
	     (vlax-invoke
	       (vlax-get-acad-object)
	       'zoomscaled
	       0.85
	       aczoomscaledrelative
	     ) ;_ конец vlax-invoke
	     t
      ) ;_ конец progn
      nil
    ) ;_ конец if
  )			      ;end
  (defun mip:entsel (promt filter entlist / key n newentlist)
;;;Функция mip:entsel
;;;Еденичный выбор объекта, замена функции entsel
;;; Возвращает entity name выбранного примитива или nil, точку
;;; указания
;;; запоминает в переменной
;;; LASTPOINT
;;;Параметры:
;;;promt - предложение выбрать объект (string)
;;;filter - фильтр объектов для выбора вида '("LINE" "LWPOLYLINE")
;;; entlist - список примитивов которые не надо выбирать (либо список
;;; entity name, либо
;;; PICKSET)
;;;
;;;Примеры:
;;;(mip:entsel "\nВыберите объекты" '("LINE" "LWPOLYLINE") nil)
;;;(mip:entsel "\nВыберите объекты" nil nil)
;;; (setq aa nil) (mip:entsel "\nВыберите объекты" '("LINE"
;;; "LWPOLYLINE")
;;; (while (setq a (car (entsel))) (setq aa (append aa (list
;;; a)))))
;;;(mip:entsel "\nВыберите объекты" '("LINE" "LWPOLYLINE") (ssget))
    (setq key t
	  n 0
	  newentlist nil
    ) ;_ конец setq
    (if	(eq (type entlist) 'pickset)
      (progn (while (setq a (ssname entlist n))
	       (setq newentlist
		      (append newentlist (list a))
		     n (1+ n)
	       ) ;_ конец setq
	     ) ;_ конец while
	     (setq entlist newentlist)
      )			      ;progn
    )			      ;if
    (while key
      (if (or (setq ent_point (entsel promt)) (= (getvar "ERRNO") 7))
	(if (or (eq (type ent_point) 'list) (not ent_point))
	  (if ent_point
	    (if	(member (setq ent (car ent_point)) entlist)
	      (princ "\nПримитив уже выбран")
	      (if filter
		(if (not (member (cdr (assoc 0 (entget ent))) filter))
		  (progn
		    (setq str "\nНе верный выбор, выберите: ")
		    (princ (substr (setq str (foreach n	filter
					       (setq str (strcat str n ", "))
					     ) ;_ конец foreach
				   ) ;_ конец setq
				   1
				   (- (strlen str) 2)
			   ) ;_ конец substr
		    ) ;_ конец princ
		  )	      ;progn
		  (setq key nil)
		)	      ;if
		(setq key nil)
	      )		      ;if
	    )		      ;if
	    (setq key t)
	  )		      ;if
	  (setq key nil)
	)		      ;if
	(setq key nil)
      )			      ;if
    )			      ;while
    (if	(eq (type ent_point) 'list)
      (progn (setvar "LASTPOINT" (cadr ent_point)) ent)
      ent_point
    )			      ;if
  )			      ;defun
  (defun mip_makeuniquemembersoflist (lst / outlist head)
;;;Удаляет одинаковые (дубликаты) элементы из списка
;;; На основе http://www.theswamp.org/index.php?topic=19128.0
;;; Изменено для сравнения вещественных чисел (equal ... 1e-6)
    (while lst
      (setq head    (car lst)
	    outlist (cons head outlist)
	    lst	    (vl-remove-if '(lambda (pt) (equal pt head 1e-6)) (cdr lst))
      ) ;_ конец setq
    ) ;_ конец while
    (reverse outlist)
  ) ;_ конец defun
  (defun mip:zzero (lst)
    (mapcar '(lambda (x) (list (car x) (cadr x))) lst)
  ) ;_ конец defun
  (defun massoc	(key alist / x nlist)
    (foreach x alist
      (if (eq key (car x))
	(setq nlist (cons (cdr x) nlist))
      ) ;_ конец if
    ) ;_ конец foreach
    (reverse nlist)
  ) ;_ конец defun
  (defun selpoly (filter-list  /	    lst		 endOfPolyLine
		  endPointOfPolyLine   questionOfReverse *error*
		  ss
		 ) ;_ конец filter-list
;;; Выделение объектов, пересекаемых полилинией
;;; Vladimir Azarko (VVA) for dwg.ru
;;;  filter-list - фильтр список, см. описание ф-ции ssget или nil
;;; http://forum.dwg.ru/showthread.php?t=82243
;;; http://www.cadtutor.net/forum/showthread.php?68857-Counting-objects-not-blocks-in-a-polyline&p=471167#post471167
    (vl-load-com)
        (if	(not polyLine)
      (setq polyLine (mip:entsel "\nВыберите полилинию" '("LWPOLYLINE") nil))
    ) ;_ конец if
    (if	polyLine
      (progn
	(setq endPointOfPolyLine (cdr (assoc 10 (reverse (entget polyLine))))
	    ) ;_ конец setq
	(entmake
	  (list	(cons 0 "CIRCLE")
		(cons 8 "0")
		(cons 10 (reverse (cons 0.0 (reverse endPointOfPolyLine))))
		(cons 40 (/ 2 (getvar "CANNOSCALEVALUE")))
		(cons 62 10)
		(cons 370 60)
	  ) ;_ конец list
	) ;_ конец entmake
	(setq endOfPolyLine (entlast))
	(_zoom2lst (massoc 10 (entget polyLine)))
	(initget "Да Нет")
	(setq questionOfReverse
	       (getkword
		 "\nУказан конец линии. \nОбратить линию?[Да/Нет]:<Нет>"
	       ) ;_ конец getpoint
	) ;_ конец setq
	(if (and questionOfReverse (equal questionOfReverse "Да"))
	  (progn (if command-s
		   (command-s "_REVERSE" polyLine "")
		   (command "_REVERSE" polyLine "")
		 ) ;_ конец if
	  ) ;_ конец progn
	) ;_ конец if
	(entdel endOfPolyLine)
	(and polyLine
	     (setq lst (massoc 10 (entget polyLine)))
	     (or (_zoom2lst lst) t)
	     (setq ss nil
		   ss (if filter-list
			(ssget "_F"
			       (mip_makeuniquemembersoflist
				 (mapcar '(lambda (x) (trans x 0 1)) lst)
			       ) ; _ конец
			      ; mip_MakeUniqueMembersOfList
			       filter-list
			) ;_ конец ssget
			(ssget "_F"
			       (mip_makeuniquemembersoflist
				 (mapcar '(lambda (x) (trans x 0 1)) lst)
			       ) ; _ конец
			      ; mip_MakeUniqueMembersOfList
			) ;_ конец ssget
		      ) ;_ конец if
	     ) ;_ конец setq
	     (sssetfirst nil ss)
	) ;_ конец and
      ) ;_ конец progn
    ) ;_ конец if
 ;_ конец if
    ss
  )
Вложения
Тип файла: dwg
DWG 2013
Пример.dwg (3.73 Мб, 11 просмотров)
__________________
Проекты СС
AlexZh вне форума  
 
Непрочитано 22.05.2019, 00:23
1 | #4
Сергей812


 
Регистрация: 10.08.2013
Сообщений: 6,323


Как минимум, лиспу не нравится - когда архитектурная подоснова в виде группы сделана)
Сергей812 вне форума  
 
Автор темы   Непрочитано 22.05.2019, 07:59
#5
AlexZh


 
Регистрация: 23.09.2015
Сообщений: 143


Цитата:
Сообщение от Сергей812 Посмотреть сообщение
Как минимум, лиспу не нравится - когда архитектурная подоснова в виде группы сделана)
Ого! Сработало!

СПАСИБИЩЕ!!!!

А почему так, а?
__________________
Проекты СС
AlexZh вне форума  
 
Непрочитано 22.05.2019, 09:46
#6
Сергей812


 
Регистрация: 10.08.2013
Сообщений: 6,323


без понятия, я таким не пользуюсь) Просто попробовал на плане пронумеровать круговой шлейф - фигня с нумерацией. Попробовал на чистом месте - прямая, змейка, контур - все отрабатывает. Скопировал группу-подложку и разместил под предыдущими опытными трассами - и снова фигня. Т.е. постепенно отсекал причины: влияет ли форма трассы, влияют ли посторонние примитивы/объекты..
Сергей812 вне форума  
 
Непрочитано 22.05.2019, 10:33
1 | #7
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,471


А если предварительно pickfirst просто поменять ?
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 22.05.2019, 16:48
1 | #8
koMon


 
Регистрация: 26.09.2017
Сообщений: 309


(setvar 'pickstyle 0)
koMon вне форума  
 
Автор темы   Непрочитано 23.05.2019, 18:04
#9
AlexZh


 
Регистрация: 23.09.2015
Сообщений: 143


Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
А если предварительно pickfirst просто поменять ?
Спасибо! Так и сделал!
__________________
Проекты СС
AlexZh вне форума  
 
Непрочитано 23.05.2019, 18:24
#10
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,471


А правильный ответ, кажется, у koMon ))
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 24.05.2019, 09:28
#11
koMon


 
Регистрация: 26.09.2017
Сообщений: 309


Алексей, видимо TopicCaster смог решить свою проблему установкой переменной pickfirst
Миниатюры
Нажмите на изображение для увеличения
Название: PF.PNG
Просмотров: 12
Размер:	12.8 Кб
ID:	214432  
koMon вне форума  
 
Автор темы   Непрочитано 25.05.2019, 13:08
#12
AlexZh


 
Регистрация: 23.09.2015
Сообщений: 143


Цитата:
Сообщение от koMon Посмотреть сообщение
Алексей, видимо TopicCaster смог решить свою проблему установкой переменной pickfirst
Да ладно Вам! Вижу одно, понимаю другое!)
__________________
Проекты СС
AlexZh вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Неправильная нумерация элементов в наборе на полилинии.

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
LISP. Как в ActiveX выдернуть координаты полилинии? Как задавать атребуты блока через LISP? wpww LISP 31 16.08.2016 14:17
Автоматическая нумерация поворотных точек участка aydinkhalil Программирование 23 02.03.2015 10:31
.NET Изобретаем велосипед, или как найти ближайшую вершину полилинии? La Persona .NET 14 05.12.2013 10:56
Неправдоподобно маленькие сечения элементов фермы при подборе в SCAD Олег 3108 SCAD 1 01.10.2012 13:25
выноски к полилинии gizmo_zx Программирование 6 01.03.2010 12:17