Альбомы технических решений и чертежи
Показать сообщение отдельно
Непрочитано 02.02.2019, 12:08 #1
Неправильная нумерация элементов в наборе на полилинии.
AlexZh
 
Регистрация: 23.09.2015
Сообщений: 145

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

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)
;*** НЕ добавляйте текст под комментариями! ***|;
__________________
Проекты СС
Просмотров: 2407
 
Размещение рекламы