Опять про Lisp-ы... (Помощь чайнику в редактировании)
| Правила | Регистрация | Пользователи | Сообщения за день |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Опять про Lisp-ы... (Помощь чайнику в редактировании)

Опять про Lisp-ы... (Помощь чайнику в редактировании)

Ответ
Перейти к новому Перейти к новому  
Поиск в этой теме
Непрочитано 23.01.2010, 11:39 #1
Опять про Lisp-ы... (Помощь чайнику в редактировании)
superkot007
 
Регистрация: 15.01.2010
Сообщений: 254
Есть простенький lisp (нашел здесь):
Код:
[Выделить все] 
 (defun c:pickblocknum (/ name tag pref suff num ss el)
  (while (= (setq name (getstring "\nИмя блока: ")) ""))
  (while (= (setq tag (getstring "\nТег: ")) ""))
  (setq tag (strcase tag))
  (setq pref (getstring "\nПрефикс: "))
  (setq suff (getstring "\nСуффикс: "))
  (if (null (setq num (getint "\nСтартовый номер: ")))
    (setq num 1)
  ) ;_  if
  (princ "\nБлоки > ")
  (if (setq ss (ssget (list '(0 . "INSERT") '(410 . "Model") (cons 2 name))))
    (while (> (sslength ss) 0)
      (setq ss (ssdel (setq el (ssname ss 0)) ss))
      ;; поиск нужного атрибута
      (while (and (/= (cdr (assoc 0 (entget el))) "SEQEND")
                  (/= (cdr (assoc 2 (entget el))) tag)
             ) ;_  or
        (setq el (entnext el))
      ) ;_  while
      ;;  если атрибут найден
      (if (= (cdr (assoc 2 (entget el))) tag)
        (progn
          (vla-put-textstring (vlax-ename->vla-object el) (strcat pref (rtos num 2 0) suff))
          (setq num (1+ num)) ;_ приращение номера
        ) ;_  progn
      ) ;_  if
    ) ;_  while
  ) ;_  if
  (princ)
) ;_  defun
(vl-load-com)
;;;(c:pickblocknum) ;_ автозапуск
У кого есть желание помочь, пожалуйста, напишите:
1. Как осуществить выбор блоков и нужного атрибута в нем "мЫшей", а не прописыванием имен в ком. строке (блок имеет около 2 десятков атрибутов со сложными названиями)?
2. Формат вводимых чисел - 001, 002, и т.д. (в принципе, префиксом можно обойтись... просто не очень удобно: сначала 00-1 по 00-9, потом с 0-10 по 0-99 и потом уже без префикса)
3. Если мне без надобности префикс и суффикс - я могу убрать
Код:
[Выделить все] 
(setq pref (getstring "\nПрефикс: "))
(setq suff (getstring "\nСуффикс: "))
?

Или тоже самое в этом:
Код:
[Выделить все] 
;;; Модификация кода Лентяй, опубликованного
;;; http://dwg.ru/f/showpost.php?p=50584&postcount=37
;;; В переменные blkname и attname вынесены названия блока и атрибута для хранения номера
;;; Полезные ссылки:
;;; Нумерация, перенумерация
;;; http://www.caduser.ru/cgi-bin/f1/board.cgi?t=33416cQ&page=1
;;; Как правильно загрузить этот лисп
;;; http://dwg.ru/art/8
(defun C:SN (/ *error* adoc att_list axss blk_list fpt num oaq oat oqa osm sort_list spt test_list cm blkname attname)
  (setq blkname "СВАЯ"  ;_ Имя блока сваи
    attname "NUM"   ;_ Имя аттрибута
  )
  (vl-load-com) 
  (defun *error* (error) 
    (cond ((not error)) 
          ((wcmatch (strcase error) "*QUIT*,*CANCEL*")) 
          (1 (princ (strcat "\nERROR: " error)))) 
    (setvar "osmode" osm)  (setvar "attdia" oat) 
    (setvar "attreq" oaq) (setvar "qaflags" oqa) 
    (setvar "cmdecho" 1) (vla-endundomark adoc) 
    (princ));defun 
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))) 
  (vla-endundomark adoc) 
  (vla-startundomark adoc) 
  (setvar "cmdecho" 0) 
  (setq oat (getvar "attdia") osm (getvar "osmode") 
        oaq (getvar "attreq") oqa (getvar "qaflags")) 
  (setvar "attdia" 0);Выводятся запросы в командной строке (окно подавляется) 
  (setvar "attreq" 0);Для каждого атрибута не выдается запрос значения    
  (setvar "qaflags" 0);Запрет вывода на экран окон предупреждений, перенос их в командную строку  
  (setvar "osmode" 0) 
  (setq fpt (getpoint "\nПервый угол рамки выбора >> \n") 
               spt (getcorner fpt "\nВторой угол рамки выбора >> \n")) 
    (if (ssget "_W" fpt spt (list (cons 0 "INSERT") (cons 2 "СВАЯ") (cons 66 1))) 
      (progn (initget 4) 
        (setq num (getint "\n\t >> Начальный номер [Enter для продолжения] : ")) 
        (if (not num) (setq num (if *last_number* *last_number* 
                            (getint "\n\t >> Первый раз номер задается обязательно  : ")))) 
        (setq axss (vla-get-activeselectionset adoc)) 
        (vlax-for a axss (setq blk_list (cons a blk_list))) 
        (initget "Вперед Назад") 
        (setq dir (getkword "\nНаправление [Вперед/Назад]: <Вперед>")) 
        (if (null dir) (setq dir "Вперед")) 
        (if (= dir "Вперед") (setq cm <) (setq cm >))  
        (setq test_list (mapcar '(lambda (x) (vlax-get x 'Insertionpoint)) blk_list) 
              sort_list (vl-sort blk_list '(lambda (e1 e2) 
                          (if (vl-every '(lambda (x) (equal (cadr x) (cadar test_list) 0.1)) test_list) 
                            (cm (abs (- (car fpt) (car (vlax-get e1 'Insertionpoint)))) 
                               (abs (- (car fpt) (car (vlax-get e2 'Insertionpoint))))) 
                            (cm (abs (- (cadr fpt) (cadr (vlax-get e1 'Insertionpoint)))) 
                               (abs (- (cadr fpt) (cadr (vlax-get e2 'Insertionpoint)))))))));setq 
        (foreach blk_obj sort_list 
          (if (and (vlax-property-available-p blk_obj 'Hasattributes) 
                   (vlax-read-enabled-p blk_obj) (vlax-write-enabled-p blk_obj)) 
            (progn (setq att_list (vlax-invoke blk_obj 'Getattributes)) 
              (foreach at att_list 
                (if (eq (strcase(vla-get-tagstring at))(strcase attname))
                  (progn (vla-put-textstring at (itoa num)) 
                    (vla-update at) (vla-update blk_obj))))));if 
          (setq num (1+ num)));foreach 
        (vla-clear axss) (vla-delete axss) 
        (vlax-release-object axss) (setq axss nil) 
        (setq blk_list nil)));if 
  (setq *last_number* num) 
  (vla-regen adoc acactiveviewport) 
  (*error* nil) 
  (princ) 
);end 
(prompt "\nВ командной строке набери SN \n") 
(princ)
P.S.: есть еще lisp-ы для "шлифовки/подгонки"
Последний раз редактировалось superkot007, 23.01.2010 в 19:39.
Просмотров: 29682
 
Непрочитано 24.01.2010, 13:24
#2
Олег (jr.)

специалист по околачиванию грушевых деревьев
 
Регистрация: 14.09.2004
Pietari, Venäjä
Сообщений: 811

Вместо этого
Код:
[Выделить все] 
(while (= (setq name (getstring "\nИмя блока: ")) ""))
  (while (= (setq tag (getstring "\nТег: ")) ""))
можно кликать на нужном атрибуте:
Код:
[Выделить все] 
(setq num 1000);<--номер от балды
(while (setq ent (nentsel "\nВыбрать атрибут (нажми Enter для завершения)>>"))
(setq el (car ent))
         (vla-put-textstring (vlax-ename->vla-object el) (strcat pref (rtos num 2 0) suff))
          (setq num (1+ num)) ;_ приращение номера
)
Олег (jr.) вне форума  
 
Автор темы   Непрочитано 24.01.2010, 14:09
#3
superkot007


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

Цитата:
Сообщение от Олег (jr.) Посмотреть сообщение
Вместо этого
Код:
[Выделить все] 
(while (= (setq name (getstring "\nИмя блока: ")) ""))
  (while (= (setq tag (getstring "\nТег: ")) ""))
можно кликать на нужном атрибуте:
Код:
[Выделить все] 
(setq num 1000);<--номер от балды
(while (setq ent (nentsel "\nВыбрать атрибут (нажми Enter для завершения)>>"))
(setq el (car ent))
         (vla-put-textstring (vlax-ename->vla-object el) (strcat pref (rtos num 2 0) suff))
          (setq num (1+ num)) ;_ приращение номера
)
Ну и? Никакого эффекта...
Код:
[Выделить все] 
Команда: pickblocknum
Выбрать атрибут (нажми Enter для завершения)>>; ошибка: неверный тип аргумента: 
stringp nil
superkot007 вне форума  
 
Непрочитано 24.01.2010, 15:00
#4
Олег (jr.)

специалист по околачиванию грушевых деревьев
 
Регистрация: 14.09.2004
Pietari, Venäjä
Сообщений: 811

Цитата:
Сообщение от superkot007 Посмотреть сообщение
Ну и? Никакого эффекта...
Код:
[Выделить все] 
Команда: pickblocknum
Выбрать атрибут (нажми Enter для завершения)>>; ошибка: неверный тип аргумента: 
stringp nil
Ну правильно ты же не задал наверно pref и suff

~'J'~
Олег (jr.) вне форума  
 
Автор темы   Непрочитано 24.01.2010, 18:39
#5
superkot007


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

Так же?
Код:
[Выделить все] 
(defun c:pickblocknum (/ name tag pref suff num ss el)
(setq num 1000);<--номер от балды
(while (setq ent (nentsel "\nВыбрать атрибут (нажми Enter для завершения)>>"))
(setq el (car ent))
         (vla-put-textstring (vlax-ename->vla-object el) (strcat pref (rtos num 2 0) suff))
          (setq num (1+ num)) ;_ приращение номера
)
  (setq tag (strcase tag))
  (setq pref (getstring "\nПрефикс: "))
  (setq suff (getstring "\nСуффикс: "))
  (if (null (setq num (getint "\nСтартовый номер: ")))
    (setq num 1)
  ) ;_  if
  (princ "\nБлоки > ")
  (if (setq ss (ssget (list '(0 . "INSERT") '(410 . "Model") (cons 2 name))))
    (while (> (sslength ss) 0)
      (setq ss (ssdel (setq el (ssname ss 0)) ss))
      ;; поиск нужного атрибута
      (while (and (/= (cdr (assoc 0 (entget el))) "SEQEND")
                  (/= (cdr (assoc 2 (entget el))) tag)
             ) ;_  or
        (setq el (entnext el))
      ) ;_  while
      ;;  если атрибут найден
      (if (= (cdr (assoc 2 (entget el))) tag)
        (progn
          (vla-put-textstring (vlax-ename->vla-object el) (strcat pref (rtos num 2 0) suff))
          (setq num (1+ num)) ;_ приращение номера
        ) ;_  progn
      ) ;_  if
    ) ;_  while
  ) ;_  if
  (princ)
) ;_  defun
(vl-load-com)
;;;(c:pickblocknum) ;_ автозапуск
Он по-моему вообще объектов не видит...
Попробовал "оригинал" - теже грабли...
superkot007 вне форума  
 
Непрочитано 26.01.2010, 11:06
1 | #6
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996

superkot007, На caduser'e было полно нумераторов. Один из них - binc. Вариант с запросом блока и выбором атрибута:
Код:
[Выделить все] 
(defun c:binc (/ oldStart oldPref oldSuf oldEcho oldInc
        oldSize oldBlock temBl *error* att attr apnum:tag pt obj )
;;;Новая версия Если в блоке несколько атрибутов, то выбирается какой нужно вставить
;;;http://forum.dwg.ru/showthread.php?t=46382
 
;==== Local functions ============
  (vl-load-com)
  (defun *error* (msg)(setvar "CMDECHO" oldEcho)(setvar "ATTDIA" att)(setvar "ATTREQ" attr)(princ)); end *error*
  (defun mydcl (zagl info-list / fl ret dcl_id)
    (if (null zagl)(setq zagl "Select")) ;_ end of if
    (setq fl (vl-filename-mktemp "mip" nil ".dcl"))
    (setq ret (open fl "w"))
    (mapcar '(lambda (x) (write-line x ret))
            (list "mip_msg : dialog { "
                  (strcat "label=\"" zagl "\";")
                  " :list_box {"
                  "alignment=top ;"
                  "width=51 ;"
                  (if (> (length info-list) 26)
                      "height= 26 ;"
                      (strcat "height= " (itoa (+ 3 (length info-list))) ";")
                  ) ;_ end of if
                  "is_tab_stop = false ;"
                  "key = \"info\";}"
                  "ok_cancel;}"
            ) ;_ end of list
    ) ;_ end of mapcar
    (setq ret (close ret))
    (if (and (not(minusp(setq dcl_id (load_dialog fl))))
	     (new_dialog "mip_msg" dcl_id))
            (progn
                (start_list "info")(mapcar 'add_list info-list)
                (end_list)(set_tile "info" "0")
                (setq ret (car info-list))
                (action_tile "info" "(setq ret (nth (atoi $value) info-list))")
                (action_tile "cancel" "(progn(setq ret nil)(done_dialog 0))")
                (action_tile "accept" "(done_dialog 1)")(start_dialog)
            ) ;_ end of progn
    ) ;_ end of if
    (unload_dialog dcl_id)(vl-file-delete fl) ret) ;_ end of defun
  (defun mip-conv-to-str (dat)
  (cond ((= (type dat) 'INT)(setq dat (itoa dat)))
         ((= (type dat) 'REAL)(setq dat (rtos dat 2 12)))
        ((null dat)(setq dat ""))
        (t (setq dat (vl-princ-to-string dat)))))
;; obj - Ename or Vla object of block
;; att_list - list ((Tag_Name1 . Value1)(Tag_Name2 . Value2) ...)
;;                 Tag_Name - string
;;                    Value - string
(defun mip-block-setattr-bylist (obj att_list / txt lst)
(if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj)))
(setq att_list (mapcar '(lambda(x)(cons (strcase (mip-conv-to-str(car x)))(mip-conv-to-str(cdr x)))) att_list))
  (if (and obj
           (not(vlax-erased-p obj))
           (= (vla-get-ObjectName obj) "AcDbBlockReference")
	   (eq :vlax-true (vla-get-HasAttributes obj))
	   (vlax-property-available-p obj 'Hasattributes)
	   (vlax-write-enabled-p obj)
      )
    (vl-catch-all-apply
      (function
	(lambda	()
          (foreach at (vlax-invoke obj 'Getattributes)
            (if (setq lst (assoc(strcase(vla-get-TagString at)) att_list))
              (vla-put-TextString at (cdr lst))
            )
            )
          )
        )
      )
    )
  )
  
  (defun get-all-atts (obj)
    ;;;Use (get-all-atts (car(entsel "\nSelect block:")))
    ;;;Returs list  (("TAG1" . "Value1")("TAG2" . "Value2") ...)
    (if (= (type obj) 'ENAME)
		(setq obj (vlax-ename->vla-object obj)))
  (if (and obj
           (vlax-property-available-p obj 'Hasattributes)
	   (eq :vlax-true (vla-get-HasAttributes obj))
      )
    (vl-catch-all-apply
      (function
	(lambda	()
	  (mapcar (function (lambda (x)
			      (cons (vla-get-TagString x)
				    (vla-get-TextString x)
			      )
			    )
		  )
		  (append (vlax-invoke obj 'Getattributes)
			  (vlax-invoke obj 'Getconstantattributes)
		  )
	  )
	)
      )
    )
  )
)
(defun rec-pat (str temp)
  (cond
    ((= str "")(if (/= temp "")(list temp)))
    ((wcmatch (substr str 1 1) "[1234567890.]")
     (rec-pat (substr str 2) (strcat temp (substr str 1 1)))
    )
    (t (if (/= temp "")
        (cons temp (rec-pat str ""))
        (rec-pat (substr str 2) "")
       ) ;_ end of if
    )
  ) ;_ end of cond
) ;_ end of defun

  
;==== Local functions END ============
  
  (if(not apnum:Size)(setq apnum:Size 1.0))
  (if(not apnum:Num)(setq apnum:Num 1))
  (if(not apnum:Inc)(setq apnum:Inc 1))
  (if(not apnum:Pref)(setq apnum:Pref ""))
  (if(not apnum:Suf)(setq apnum:Suf ""))
  (setq  oldStart apnum:Num oldSize apnum:Size oldInc apnum:Inc
         oldPref apnum:Pref oldSuf apnum:Suf
         apnum:Block (mip-conv-to-str apnum:Block)
         apnum:tag (mip-conv-to-str apnum:tag)
         oldEcho (getvar "CMDECHO")
         att (getvar "ATTDIA") attr (getvar "ATTREQ")); end setq
  (setvar "ATTDIA" 0)(setvar "ATTREQ" 0)
  (setvar "CMDECHO" 0)
    (setq apnum:Pref
    (getstring T
      (strcat "\nType prefix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"apnum:Pref"> :")))
  (if(= "" apnum:Pref)(setq apnum:Pref oldPref))
  (if(= " " apnum:Pref)(setq apnum:Pref ""))
  (setq apnum:Suf
    (getstring T
       (strcat "\nType suffix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"apnum:Suf"> :")))
  (if(= "" apnum:Suf)(setq apnum:Suf oldSuf))
  (if(= " " apnum:Suf)(setq apnum:Suf ""))
  (if apnum:Block(setq oldBlock apnum:Block))
  (setq temBl
     (entsel(strcat "\nSelect block <"
         (if apnum:Block apnum:Block "not difined") "> > "))); end setq
  (cond
    ((or (and tembl (= 1 (cdr(assoc 66(entget(car temBl)))))
	  (= "INSERT" (cdr(assoc 0(entget(car temBl)))))
	  )
	 (and apnum:Block (setq tembl (tblobjname "BLOCK" apnum:Block))
	      (setq tembl (list tembl))
	      )
	 )
     (setq apnum:Block
     (cond
           ((and (vlax-property-available-p (setq obj (vlax-ename->vla-object(car temBl))) 'isdynamicblock)
                 (= (vla-get-isdynamicblock obj) :vlax-true)
                 ) ;_ end of and
            (vla-get-effectivename obj)
            )
           (t (vla-get-name obj))
           )
	   )
;;;      (setq apnum:Block(cdr(assoc 2(entget(car temBl)))))
      ((lambda( / lst e1 ed ss i)
        (setq e1 (entnext (car temBl)))
        (while (AND e1
		  (wcmatch (cdr (assoc 0 (setq ed (entget e1)))) "ATTRIB,ATTDEF")
	     ) ;_ End of AND
	  (setq lst (cons (cdr (assoc 2 ed)) lst))
	  (setq e1 (entnext e1))
	)
	 (cond ((= 0 (length lst))(setq apnum:Block nil))
	       ((= 1 (length lst))(setq apnum:tag (car lst)))
	       (t (setq apnum:tag (mydcl "Select attribute" (acad_strlsort lst))))
	       )
;;; Максимальный номер берется как максимальное число всех значений атрибутов
;;; Высчитыватся так (допустим значение атрибута   D3SE/0-008A18B3:
;;;        Значение префикса D3SE/0-
;;;        Значение суффикса B3 
;;;         1. Из значения атрибута удаляется префикс и суффикс
;;;                Значение атрибута - 008A18
;;;         2. В значении атрибута выбираются все цифры ("008" "18")
;;;         3. Из них за число атрибута берется число с максимальной последовательностью цифр
;;;                    т.е. 8, а не 18
	 
	 (and
	   (setq ss nil ss (ssget "_X" (list
				'(0 . "INSERT")
				(cons 2  apnum:Block)
				(cons 410 (getvar "CTAB")))))
	   (setq lst nil i '-1)
	   (progn
	     (repeat (sslength ss)
	        (setq lst (cons (ssname ss (setq i (1+ i))) lst))
	       )
	     lst
	     )
         (setq apnum:Num (1+
	      (apply
		'max
	        (mapcar 'atoi
                (mapcar 'mip-conv-to-str        
	        (mapcar '(lambda(f / mst)
			   (setq mst (apply 'max (mapcar 'strlen f)))
			   (car(vl-remove-if-not '(lambda(f1)(= mst (strlen f1))) f))
			   )
	        (mapcar '(lambda(z)(rec-pat z ""))
		(mapcar '(lambda(y)
	         (vl-string-right-trim (mip-conv-to-str apnum:Suf)
		 (vl-string-left-trim apnum:pref y)))
		 (vl-remove-if 'null (mapcar '(lambda(x)(cdr(assoc (strcase apnum:tag)(get-all-atts x)))) lst)))
		)))))))
	   );_and
	 );_lambda
	);_lambda
    ); end condition #2
    ((null (tblsearch "BLOCK" apnum:Block))
     (alert (strcat "Block " apnum:Block " not found"))
     (setq apnum:Block nil)
     ); end condition #0
    ((and apnum:Block(not temBl)(tblsearch "BLOCK" apnum:Block))
    (setq apnum:Block oldBlock)
     ); end condition #1
    
    (t
     (princ "\nBlock not contains attribute! ")
     (setq apnum:Block nil)
     ); end condition #3
    ); end cond  
  (setq apnum:Num
    (getint
      (strcat "\nSpecify start number <"(itoa apnum:Num)">: ")))
  (if(null apnum:Num)(setq apnum:Num oldStart))
  (setq apnum:Inc
    (getint
      (strcat "\nSpecify increment <"(itoa apnum:Inc)">: ")))
  (if(null apnum:Inc)(setq apnum:Inc oldInc))
  (setq apnum:Size
    (getreal
      (strcat "\nSpecify block scale <"(rtos apnum:Size)">: ")))
  (if(null apnum:Size)(setq apnum:Size oldSize))

  (if (and apnum:Block apnum:tag)
    (progn
(while T
  (princ "\n>>> Pick insertion point or press Esc to quit <<<\n")
  (command "_-insert" apnum:Block "_s" apnum:Size pause "0")
   (mip-block-setattr-bylist (entlast)
     (list(cons (strcase (mip-conv-to-str apnum:tag))
                (strcat apnum:Pref(itoa apnum:Num)apnum:Suf))))
    (setq apnum:Num (+ apnum:Num apnum:Inc))
  ); end while
); end progn
    ); end if
  (setvar "ATTDIA" att)(setvar "ATTREQ" attr)
  (princ)
  )
__________________
Как использовать код на Лиспе читаем здесь
Последний раз редактировалось VVA, 27.01.2013 в 15:37. Причина: Имя динамического блока
VVA вне форума  
 
Автор темы   Непрочитано 26.01.2010, 19:14
#7
superkot007


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

VVA
Супер! Что-то сначала затупил, вхождения блока
не обновил, поэтому выдал "Блок не найден"...
1. А можно номер в формате 0000-9999 сразу получать, без префикса (если геморройно, то не надо...)
Скрестить, так сказать, с другим Вашим произведением:
Код:
[Выделить все] 
;;ApnumAlign
(defun c:apnumA (/ oldStart oldPref oldSuf oldEcho
        oldSize  oldBlock temBl *error* att)
  (defun *error* (msg)
    (setvar  "CMDECHO" oldEcho)
   (setvar "ATTDIA" att)
    (princ)
    );  end *error*
  (if(not apnum:Size)(setq apnum:Size 1.0))
  (if(not  apnum:Num)(setq apnum:Num 1))
  (if(not apnum:Alig)(setq apnum:Alig  "1"))
  (if(not apnum:Pref)(setq apnum:Pref ""))
  (if(not  apnum:Suf)(setq apnum:Suf ""))
  (setq  oldStart apnum:Num
    oldSize apnum:Size
   oldPref apnum:Pref
   oldSuf apnum:Suf
    oldEcho(getvar "CMDECHO")
   att (getvar "ATTDIA")
   ); end setq
  (setvar  "ATTDIA" 0)(setvar "ATTREQ" 1)
  (setvar "CMDECHO" 0)
    (setq  apnum:Pref
    (getstring T
      (strcat "\nУкажите префиксДля удаления префикса наберите  ' ' (нажать клавишу SPACE на клавиатуре) <"apnum:Pref"> :")))
  (if(=  "" apnum:Pref)(setq apnum:Pref oldPref))
  (if(= " "  apnum:Pref)(setq apnum:Pref ""))
  (setq apnum:Suf
    (getstring T
        (strcat "\nУкажите суффиксДля удаления суффикса наберите  ' ' (нажать клавишу SPACE на клавиатуре) <"apnum:Suf"> :")))
  (if(=  "" apnum:Suf)(setq apnum:Suf oldSuf))
  (if(= " " apnum:Suf)(setq  apnum:Suf ""))
  (setq apnum:Num
    (getint
      (strcat  "\nУкажите начальный номер <"(itoa apnum:Num)">: ")))
  (if(null  apnum:Num)(setq apnum:Num oldStart))
   (setq  oldStart apnum:Alig)
  (initget  "1 10 100 1000 10000 100000")
  (setq apnum:Alig
    (GETKWORD
      (strcat  "\nУкажите варавнивание начального номера [1/10/100/1000/10000/100000]  <"apnum:Alig">: ")))
  (if(null apnum:Alig)(setq apnum:Alig  oldStart))
    (setq apnum:Size
    (getreal
      (strcat  "\nУкажите масштаб блока <"(rtos apnum:Size)">: ")))
  (if(null  apnum:Size)(setq apnum:Size oldSize))
  (if apnum:Block(setq  oldBlock apnum:Block))
  (setq temBl
     (entsel(strcat  "\nВыберите блок <"
         (if apnum:Block apnum:Block "не  определен") "> > "))); end setq
  (cond
    ((and  apnum:Block(not temBl)(tblsearch "BLOCK" apnum:Block))
    (setq  apnum:Block oldBlock)
     ); end condition #1
    ((= 1  (cdr(assoc 66(entget(car temBl)))))
    (setq apnum:Block(cdr(assoc  2(entget(car temBl)))))
    ); end condition #2
    (t
      (princ "\nБлок не сожержит атрибутов! ")
     (setq apnum:Block nil)
      ); end condition #3
    ); end cond
  (if apnum:Block
    (progn
      (princ  "\n>>> Укажите точку вставки или нажмите Esc для выхода  <<<\n ")
(while T
  (setq temBl (itoa apnum:Num))
  (while  (< (strlen temBl)(1- (strlen apnum:Alig)))
    (setq temBl  (strcat "0" temBl)))
  (command "_-insert" apnum:Block "_s"  apnum:Size pause "0"
       (strcat apnum:Pref
          temBl
           apnum:Suf)); end command
    (setq apnum:Num (1+ apnum:Num))
  );  end while
); end progn
    ); end if
  (setvar "ATTDIA" att)
  (princ)
  )
2. А если блоки УЖЕ проставлены, можно по выбору нумеровать? (как в pickblocknum.lsp, только с выбором блоков/атрибутов мышкой; проверка на ошибки не нужна...)
3. А как быть, если блок динамический (выноска, например, с заданными параметрами видимости)...
Последний раз редактировалось superkot007, 26.01.2010 в 19:51.
superkot007 вне форума  
 
Непрочитано 26.01.2010, 20:09
2 | #8
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996

Цитата:
Сообщение от superkot007 Посмотреть сообщение
1. А можно номер в формате 0000-9999 сразу получать, без префикса (если геморройно, то не надо...)

Код:
[Выделить все] 
(defun c:bincA (/ oldStart oldPref oldSuf oldEcho oldInc oldStart
        oldSize oldBlock temBl *error* att attr apnum:tag pt temBl )
;;;Новая версия Если в блоке несколько атрибутов, то выбирается какой нужно вставить
;;; Выравнивание значения атрибута (добавление 0 перед значением)
;;;http://forum.dwg.ru/showthread.php?t=46382
 
;==== Local functions ============
  (vl-load-com)
  (defun *error* (msg)(setvar "CMDECHO" oldEcho)(setvar "ATTDIA" att)(setvar "ATTREQ" attr)(princ)); end *error*
  (defun mydcl (zagl info-list / fl ret dcl_id)
    (if (null zagl)(setq zagl "Select")) ;_ end of if
    (setq fl (vl-filename-mktemp "mip" nil ".dcl"))
    (setq ret (open fl "w"))
    (mapcar '(lambda (x) (write-line x ret))
            (list "mip_msg : dialog { "
                  (strcat "label=\"" zagl "\";")
                  " :list_box {"
                  "alignment=top ;"
                  "width=51 ;"
                  (if (> (length info-list) 26)
                      "height= 26 ;"
                      (strcat "height= " (itoa (+ 3 (length info-list))) ";")
                  ) ;_ end of if
                  "is_tab_stop = false ;"
                  "key = \"info\";}"
                  "ok_cancel;}"
            ) ;_ end of list
    ) ;_ end of mapcar
    (setq ret (close ret))
    (if (and (not(minusp(setq dcl_id (load_dialog fl))))
	     (new_dialog "mip_msg" dcl_id))
            (progn
                (start_list "info")(mapcar 'add_list info-list)
                (end_list)(set_tile "info" "0")
                (setq ret (car info-list))
                (action_tile "info" "(setq ret (nth (atoi $value) info-list))")
                (action_tile "cancel" "(progn(setq ret nil)(done_dialog 0))")
                (action_tile "accept" "(done_dialog 1)")(start_dialog)
            ) ;_ end of progn
    ) ;_ end of if
    (unload_dialog dcl_id)(vl-file-delete fl) ret) ;_ end of defun
  (defun mip-conv-to-str (dat)
  (cond ((= (type dat) 'INT)(setq dat (itoa dat)))
         ((= (type dat) 'REAL)(setq dat (rtos dat 2 12)))
        ((null dat)(setq dat ""))
        (t (setq dat (vl-princ-to-string dat)))))
;; obj - Ename or Vla object of block
;; att_list - list ((Tag_Name1 . Value1)(Tag_Name2 . Value2) ...)
;;                 Tag_Name - string
;;                    Value - string
(defun mip-block-setattr-bylist (obj att_list / txt lst)
(if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj)))
(setq att_list (mapcar '(lambda(x)(cons (strcase (mip-conv-to-str(car x)))(mip-conv-to-str(cdr x)))) att_list))
  (if (and obj
           (not(vlax-erased-p obj))
           (= (vla-get-ObjectName obj) "AcDbBlockReference")
	   (eq :vlax-true (vla-get-HasAttributes obj))
	   (vlax-property-available-p obj 'Hasattributes)
	   (vlax-write-enabled-p obj)
      )
    (vl-catch-all-apply
      (function
	(lambda	()
          (foreach at (vlax-invoke obj 'Getattributes)
            (if (setq lst (assoc(strcase(vla-get-TagString at)) att_list))
              (vla-put-TextString at (cdr lst))
            )
            )
          )
        )
      )
    )
  )
  (defun get-all-atts (obj)
    ;;;Use (get-all-atts (car(entsel "\nSelect block:")))
    ;;;Returs list  (("TAG1" . "Value1")("TAG2" . "Value2") ...)
    (if (= (type obj) 'ENAME)
		(setq obj (vlax-ename->vla-object obj)))
  (if (and obj
           (vlax-property-available-p obj 'Hasattributes)
	   (eq :vlax-true (vla-get-HasAttributes obj))
      )
    (vl-catch-all-apply
      (function
	(lambda	()
	  (mapcar (function (lambda (x)
			      (cons (vla-get-TagString x)
				    (vla-get-TextString x)
			      )
			    )
		  )
		  (append (vlax-invoke obj 'Getattributes)
			  (vlax-invoke obj 'Getconstantattributes)
		  )
	  )
	)
      )
    )
  )
)
(defun rec-pat (str temp)
  (cond
    ((= str "")(if (/= temp "")(list temp)))
    ((wcmatch (substr str 1 1) "[1234567890.]")
     (rec-pat (substr str 2) (strcat temp (substr str 1 1)))
    )
    (t (if (/= temp "")
        (cons temp (rec-pat str ""))
        (rec-pat (substr str 2) "")
       ) ;_ end of if
    )
  ) ;_ end of cond
) ;_ end of defun

  
;==== Local functions END ============
  
  (if(not apnum:Size)(setq apnum:Size 1.0))
  (if(not apnum:Num)(setq apnum:Num 1))
  (if(not apnum:Inc)(setq apnum:Inc 1))
  (if(not apnum:Pref)(setq apnum:Pref ""))
  (if(not apnum:Suf)(setq apnum:Suf ""))
  (if(not apnum:Alig)(setq apnum:Alig "1"))
  (setq  oldStart apnum:Num oldSize apnum:Size oldInc apnum:Inc
         oldPref apnum:Pref oldSuf apnum:Suf
         apnum:Block (mip-conv-to-str apnum:Block)
         apnum:tag (mip-conv-to-str apnum:tag)
         oldEcho (getvar "CMDECHO")
         att (getvar "ATTDIA") attr (getvar "ATTREQ")); end setq
  (setvar "ATTDIA" 0)(setvar "ATTREQ" 0)
  (setvar "CMDECHO" 0)
    (setq apnum:Pref
    (getstring T
      (strcat "\nType prefix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"apnum:Pref"> :")))
  (if(= "" apnum:Pref)(setq apnum:Pref oldPref))
  (if(= " " apnum:Pref)(setq apnum:Pref ""))
  (setq apnum:Suf
    (getstring T
       (strcat "\nType suffix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"apnum:Suf"> :")))
  (if(= "" apnum:Suf)(setq apnum:Suf oldSuf))
  (if(= " " apnum:Suf)(setq apnum:Suf ""))
  (if apnum:Block(setq oldBlock apnum:Block))
  (setq temBl
     (entsel(strcat "\nSelect block <"
         (if apnum:Block apnum:Block "not difined") "> > "))); end setq
  (cond
    ((or (and tembl (= 1 (cdr(assoc 66(entget(car temBl)))))
	  (= "INSERT" (cdr(assoc 0(entget(car temBl)))))
	  )
	 (and apnum:Block (setq tembl (tblobjname "BLOCK" apnum:Block))
	      (setq tembl (list tembl))
	      )
	 )
      (setq apnum:Block(cdr(assoc 2(entget(car temBl)))))
      ((lambda( / lst e1 ed ss i)
        (setq lst nil e1 (car temBl))
        (while e1
          (if (wcmatch (cdr (assoc 0 (setq ed (entget e1)))) "ATTRIB,ATTDEF")
	     (setq lst (cons (cdr (assoc 2 ed)) lst))
            )
	  (setq e1 (entnext e1))
	)
	 (cond ((= 0 (length lst))(setq apnum:Block nil))
	       ((= 1 (length lst))(setq apnum:tag (car lst)))
	       (t (setq apnum:tag (mydcl "Select attribute" (acad_strlsort lst))))
	       )
;;; Максимальный номер берется как максимальное число всех значений атрибутов
;;; Высчитыватся так (допустим значение атрибута   D3SE/0-008A18B3:
;;;        Значение префикса D3SE/0-
;;;        Значение суффикса B3 
;;;         1. Из значения атрибута удаляется префикс и суффикс
;;;                Значение атрибута - 008A18
;;;         2. В значении атрибута выбираются все цифры ("008" "18")
;;;         3. Из них за число атрибута берется число с максимальной последовательностью цифр
;;;                    т.е. 8, а не 18
	 (and apnum:Block
	   (setq ss nil ss (ssget "_X" (list
				'(0 . "INSERT")
				(cons 2  apnum:Block)
				(cons 410 (getvar "CTAB")))))
	   (setq lst nil i '-1)
	   (progn
	     (repeat (sslength ss)
	        (setq lst (cons (ssname ss (setq i (1+ i))) lst))
	       )
	     lst
	     )
         (setq apnum:Num (1+
	      (apply
		'max
	        (mapcar 'atoi
                (mapcar 'mip-conv-to-str        
	        (mapcar '(lambda(f / mst)
			   (setq mst (apply 'max (mapcar 'strlen f)))
			   (car(vl-remove-if-not '(lambda(f1)(= mst (strlen f1))) f))
			   )
	        (mapcar '(lambda(z)(rec-pat z ""))
		(mapcar '(lambda(y)
	         (vl-string-right-trim (mip-conv-to-str apnum:Suf)
		 (vl-string-left-trim apnum:pref y)))
		 (vl-remove-if 'null (mapcar '(lambda(x)(cdr(assoc (strcase apnum:tag)(get-all-atts x)))) lst)))
		)))))))
	   );_and
	 );_lambda
	);_lambda
    ); end condition #2
    ((null (tblsearch "BLOCK" apnum:Block))
     (alert (strcat "Block " apnum:Block " not found"))
     (setq apnum:Block nil)
     ); end condition #0
    ((and apnum:Block(not temBl)(tblsearch "BLOCK" apnum:Block))
    (setq apnum:Block oldBlock)
     ); end condition #1
    
    (t
     (princ "\nBlock not contains attribute! ")
     (setq apnum:Block nil)
     ); end condition #3
    ); end cond
  (setq oldStart apnum:Num)
  (setq apnum:Num
    (getint
      (strcat "\nSpecify start number <"(itoa apnum:Num)">: ")))
  (if(null apnum:Num)(setq apnum:Num oldStart))
  (setq apnum:Inc
    (getint
      (strcat "\nSpecify increment <"(itoa apnum:Inc)">: ")))
  (if(null apnum:Inc)(setq apnum:Inc oldInc))
     (setq  oldStart apnum:Alig)
  (initget "1 10 100 1000 10000 100000")
  (setq apnum:Alig 
    (GETKWORD 
      (strcat "\nSpecify the alignment of the initial number [1/10/100/1000/10000/100000] <"apnum:Alig">: ")))
  (if(null apnum:Alig)(setq apnum:Alig oldStart))

  (setq apnum:Size
    (getreal
      (strcat "\nSpecify block scale <"(rtos apnum:Size)">: ")))
  (if(null apnum:Size)(setq apnum:Size oldSize))

  (if (and apnum:Block apnum:tag)
    (progn
(while T
  (princ "\n>>> Pick insertion point or press Esc to quit <<<\n")
    (setq temBl (itoa apnum:Num))
  (while (< (strlen temBl)(1- (strlen apnum:Alig)))
    (setq temBl (strcat "0" temBl)))
  (command "_-insert" apnum:Block "_s" apnum:Size pause "0")
   (mip-block-setattr-bylist (entlast)
     (list(cons (strcase (mip-conv-to-str apnum:tag))
                (strcat apnum:Pref temBl apnum:Suf))))
    (setq apnum:Num (+ apnum:Num apnum:Inc))
  ); end while
); end progn
    ); end if
  (setvar "ATTDIA" att)(setvar "ATTREQ" attr)
  (princ)
  )


Цитата:
Сообщение от superkot007 Посмотреть сообщение
А если блоки УЖЕ проставлены, можно по выбору нумеровать? (как в pickblocknum.lsp, только с выбором блоков/атрибутов мышкой; проверка на ошибки не нужна...)

Код:
[Выделить все] 
(defun c:pickblocknum (/         oldStart  oldPref   oldSuf
                       oldEcho   oldInc    oldSize   oldBlock
                       temBl     *error*   att       attr
                       apnum:tag pt        el
                      )
;;;Новая версия Если в блоке несколько атрибутов, то выбирается какой нужно вставить
;;;http://forum.dwg.ru/showthread.php?t=46382

                                                  ;==== Local functions ============
  (vl-load-com)
  (defun *error* (msg)
    (setvar "CMDECHO" oldEcho)
    (setvar "ATTDIA" att)
    (setvar "ATTREQ" attr)
    (princ)
  )                                               ; end *error*
  (defun mydcl (zagl info-list / fl ret dcl_id)
    (if (null zagl)
      (setq zagl "Select")
    ) ;_ end of if
    (setq fl (vl-filename-mktemp "mip" nil ".dcl"))
    (setq ret (open fl "w"))
    (mapcar
      '(lambda (x) (write-line x ret))
      (list "mip_msg : dialog { "
            (strcat "label=\"" zagl "\";")
            " :list_box {"
            "alignment=top ;"
            "width=51 ;"
            (if (> (length info-list) 26)
              "height= 26 ;"
              (strcat "height= " (itoa (+ 3 (length info-list))) ";")
            ) ;_ end of if
            "is_tab_stop = false ;"
            "key = \"info\";}"
            "ok_cancel;}"
      ) ;_ end of list
    ) ;_ end of mapcar
    (setq ret (close ret))
    (if (and (not (minusp (setq dcl_id (load_dialog fl))))
             (new_dialog "mip_msg" dcl_id)
        ) ;_ end of and
      (progn
        (start_list "info")
        (mapcar 'add_list info-list)
        (end_list)
        (set_tile "info" "0")
        (setq ret (car info-list))
        (action_tile
          "info"
          "(setq ret (nth (atoi $value) info-list))"
        ) ;_ end of action_tile
        (action_tile
          "cancel"
          "(progn(setq ret nil)(done_dialog 0))"
        ) ;_ end of action_tile
        (action_tile "accept" "(done_dialog 1)")
        (start_dialog)
      ) ;_ end of progn
    ) ;_ end of if
    (unload_dialog dcl_id)
    (vl-file-delete fl)
    ret
  ) ;_ end of defun
  (defun mip-conv-to-str (dat)
    (cond ((= (type dat) 'INT) (setq dat (itoa dat)))
          ((= (type dat) 'REAL) (setq dat (rtos dat 2 12)))
          ((null dat) (setq dat ""))
          (t (setq dat (vl-princ-to-string dat)))
    ) ;_ end of cond
  ) ;_ end of defun
  ;; obj - Ename or Vla object of block
  ;; att_list - list ((Tag_Name1 . Value1)(Tag_Name2 . Value2) ...)
  ;;                 Tag_Name - string
  ;;                    Value - string
  (defun mip-block-setattr-bylist (obj att_list / txt lst)
    (if (= (type obj) 'ENAME)
      (setq obj (vlax-ename->vla-object obj))
    ) ;_ end of if
    (setq
      att_list (mapcar '(lambda (x)
                          (cons (strcase (mip-conv-to-str (car x)))
                                (mip-conv-to-str (cdr x))
                          ) ;_ end of cons
                        ) ;_ end of lambda
                       att_list
               ) ;_ end of mapcar
    ) ;_ end of setq
    (if (and obj
             (not (vlax-erased-p obj))
             (= (vla-get-objectname obj) "AcDbBlockReference")
             (eq :vlax-true (vla-get-hasattributes obj))
             (vlax-property-available-p obj 'Hasattributes)
             (vlax-write-enabled-p obj)
        ) ;_ end of and
      (vl-catch-all-apply
        (function
          (lambda ()
            (foreach at (vlax-invoke obj 'Getattributes)
              (if (setq lst
                         (assoc (strcase (vla-get-tagstring at)) att_list)
                  ) ;_ end of setq
                (vla-put-textstring at (cdr lst))
              ) ;_ end of if
            ) ;_ end of foreach
          ) ;_ end of lambda
        ) ;_ end of function
      ) ;_ end of vl-catch-all-apply
    ) ;_ end of if
  ) ;_ end of defun

  (defun get-all-atts (obj)
;;;Use (get-all-atts (car(entsel "\nSelect block:")))
;;;Returs list  (("TAG1" . "Value1")("TAG2" . "Value2") ...)
    (if (= (type obj) 'ENAME)
      (setq obj (vlax-ename->vla-object obj))
    ) ;_ end of if
    (if (and obj
             (vlax-property-available-p obj 'Hasattributes)
             (eq :vlax-true (vla-get-hasattributes obj))
        ) ;_ end of and
      (vl-catch-all-apply
        (function
          (lambda ()
            (mapcar (function (lambda (x)
                                (cons (vla-get-tagstring x)
                                      (vla-get-textstring x)
                                ) ;_ end of cons
                              ) ;_ end of lambda
                    ) ;_ end of function
                    (append (vlax-invoke obj 'Getattributes)
                            (vlax-invoke obj 'Getconstantattributes)
                    ) ;_ end of append
            ) ;_ end of mapcar
          ) ;_ end of lambda
        ) ;_ end of function
      ) ;_ end of vl-catch-all-apply
    ) ;_ end of if
  ) ;_ end of defun
  (defun rec-pat (str temp)
    (cond
      ((= str "")
       (if (/= temp "")
         (list temp)
       ) ;_ end of if
      )
      ((wcmatch (substr str 1 1) "[1234567890.]")
       (rec-pat (substr str 2) (strcat temp (substr str 1 1)))
      )
      (t
       (if (/= temp "")
         (cons temp (rec-pat str ""))
         (rec-pat (substr str 2) "")
       ) ;_ end of if
      )
    ) ;_ end of cond
  ) ;_ end of defun


                                                  ;==== Local functions END ============

  (if (not apnum:Size)
    (setq apnum:Size 1.0)
  ) ;_ end of if
  (if (not apnum:Num)
    (setq apnum:Num 1)
  ) ;_ end of if
  (if (not apnum:Inc)
    (setq apnum:Inc 1)
  ) ;_ end of if
  (if (not apnum:Pref)
    (setq apnum:Pref "")
  ) ;_ end of if
  (if (not apnum:Suf)
    (setq apnum:Suf "")
  ) ;_ end of if
  (setq oldStart    apnum:Num
        oldSize     apnum:Size
        oldInc      apnum:Inc
        oldPref     apnum:Pref
        oldSuf      apnum:Suf
        apnum:Block (mip-conv-to-str apnum:Block)
        apnum:tag   (mip-conv-to-str apnum:tag)
        oldEcho     (getvar "CMDECHO")
        att         (getvar "ATTDIA")
        attr        (getvar "ATTREQ")
  )                                               ; end setq
  (setvar "ATTDIA" 0)
  (setvar "ATTREQ" 0)
  (setvar "CMDECHO" 0)
  (setq apnum:Pref
         (getstring
           t
           (strcat
             "\nType prefix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"
             apnum:Pref
             "> :"
           ) ;_ end of strcat
         ) ;_ end of getstring
  ) ;_ end of setq
  (if (= "" apnum:Pref)
    (setq apnum:Pref oldPref)
  ) ;_ end of if
  (if (= " " apnum:Pref)
    (setq apnum:Pref "")
  ) ;_ end of if
  (setq apnum:Suf
         (getstring
           t
           (strcat
             "\nType suffix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"
             apnum:Suf
             "> :"
           ) ;_ end of strcat
         ) ;_ end of getstring
  ) ;_ end of setq
  (if (= "" apnum:Suf)
    (setq apnum:Suf oldSuf)
  ) ;_ end of if
  (if (= " " apnum:Suf)
    (setq apnum:Suf "")
  ) ;_ end of if
  (if apnum:Block
    (setq oldBlock apnum:Block)
  ) ;_ end of if
  (setq temBl
         (entsel (strcat "\nSelect block <"
                         (if apnum:Block
                           apnum:Block
                           "not difined"
                         ) ;_ end of if
                         "> > "
                 ) ;_ end of strcat
         ) ;_ end of entsel
  )                                               ; end setq
  (cond
    ((or (and tembl
              (= 1 (cdr (assoc 66 (entget (car temBl)))))
              (= "INSERT" (cdr (assoc 0 (entget (car temBl)))))
         ) ;_ end of and
         (and apnum:Block
              (setq tembl (tblobjname "BLOCK" apnum:Block))
              (setq tembl (list tembl))
         ) ;_ end of and
     ) ;_ end of or
     (setq apnum:Block (cdr (assoc 2 (entget (car temBl)))))
     ((lambda (/ lst e1 ed ss i)
        (setq e1 (entnext (car temBl)))
        (while (and e1
                    (wcmatch (cdr (assoc 0 (setq ed (entget e1))))
                             "ATTRIB,ATTDEF"
                    ) ;_ end of wcmatch
               ) ;_ End of AND
          (setq lst (cons (cdr (assoc 2 ed)) lst))
          (setq e1 (entnext e1))
        ) ;_ end of while
        (cond ((= 0 (length lst)) (setq apnum:Block nil))
              ((= 1 (length lst)) (setq apnum:tag (car lst)))
              (t
               (setq
                 apnum:tag (mydcl "Select attribute" (acad_strlsort lst))
               ) ;_ end of setq
              )
        ) ;_ end of cond
;;; Максимальный номер берется как максимальное число всех значений атрибутов
;;; Высчитыватся так (допустим значение атрибута   D3SE/0-008A18B3:
;;;        Значение префикса D3SE/0-
;;;        Значение суффикса B3 
;;;         1. Из значения атрибута удаляется префикс и суффикс
;;;                Значение атрибута - 008A18
;;;         2. В значении атрибута выбираются все цифры ("008" "18")
;;;         3. Из них за число атрибута берется число с максимальной последовательностью цифр
;;;                    т.е. 8, а не 18

        (and
          (setq ss nil
                ss (ssget "_X"
                          (list
                            '(0 . "INSERT")
                            (cons 2 apnum:Block)
                            (cons 410 (getvar "CTAB"))
                          ) ;_ end of list
                   ) ;_ end of ssget
          ) ;_ end of setq
          (setq lst nil
                i   '-1
          ) ;_ end of setq
          (progn
            (repeat (sslength ss)
              (setq lst (cons (ssname ss (setq i (1+ i))) lst))
            ) ;_ end of repeat
            lst
          ) ;_ end of progn
          (setq apnum:Num
                 (1+
                   (apply
                     'max
                     (mapcar
                       'atoi
                       (mapcar
                         'mip-conv-to-str
                         (mapcar
                           '(lambda (f / mst)
                              (setq mst
                                     (apply 'max (mapcar 'strlen f))
                              ) ;_ end of setq
                              (car
                                (vl-remove-if-not
                                  '(lambda (f1) (= mst (strlen f1)))
                                  f
                                ) ;_ end of vl-remove-if-not
                              ) ;_ end of car
                            ) ;_ end of lambda
                           (mapcar
                             '(lambda (z) (rec-pat z ""))
                             (mapcar
                               '(lambda (y)
                                  (vl-string-right-trim
                                    (mip-conv-to-str apnum:Suf)
                                    (vl-string-left-trim
                                      apnum:pref
                                      y
                                    ) ;_ end of vl-string-left-trim
                                  ) ;_ end of vl-string-right-trim
                                ) ;_ end of lambda
                               (vl-remove-if
                                 'null
                                 (mapcar
                                   '(lambda (x)
                                      (cdr (assoc (strcase apnum:tag)
                                                  (get-all-atts x)
                                           ) ;_ end of assoc
                                      ) ;_ end of cdr
                                    ) ;_ end of lambda
                                   lst
                                 ) ;_ end of mapcar
                               ) ;_ end of vl-remove-if
                             ) ;_ end of mapcar
                           ) ;_ end of mapcar
                         ) ;_ end of mapcar
                       ) ;_ end of mapcar
                     ) ;_ end of mapcar
                   ) ;_ end of apply
                 ) ;_ end of 1+
          ) ;_ end of setq
        ) ;_and
      ) ;_lambda
     ) ;_lambda
    )                                             ; end condition #2
    ((null (tblsearch "BLOCK" apnum:Block))
     (alert (strcat "Block " apnum:Block " not found"))
     (setq apnum:Block nil)
    )                                             ; end condition #0
    ((and apnum:Block
          (not temBl)
          (tblsearch "BLOCK" apnum:Block)
     ) ;_ end of and
     (setq apnum:Block oldBlock)
    )                                             ; end condition #1

    (t
     (princ "\nBlock not contains attribute! ")
     (setq apnum:Block nil)
    )                                             ; end condition #3
  )                                               ; end cond  
  (setq apnum:Num
         (getint
           (strcat "\nSpecify start number <" (itoa apnum:Num) ">: ")
         ) ;_ end of getint
  ) ;_ end of setq
  (if (null apnum:Num)
    (setq apnum:Num oldStart)
  ) ;_ end of if
  (setq apnum:Inc
         (getint
           (strcat "\nSpecify increment <" (itoa apnum:Inc) ">: ")
         ) ;_ end of getint
  ) ;_ end of setq
  (if (null apnum:Inc)
    (setq apnum:Inc oldInc)
  ) ;_ end of if

  (if (and apnum:Block
           apnum:tag
           (setq
             ss (ssget "_:L" (list '(0 . "INSERT") (cons 2 apnum:Block)))
           ) ;_ end of setq
      ) ;_ end of and
    (progn
      (while (> (sslength ss) 0)
        (setq ss (ssdel (setq el (ssname ss 0)) ss))
        ;; поиск нужного атрибута
        (mip-block-setattr-bylist
          el
          (list (cons (strcase (mip-conv-to-str apnum:tag))
                      (strcat apnum:Pref (itoa apnum:Num) apnum:Suf)
                ) ;_ end of cons
          ) ;_ end of list
        ) ;_ end of mip-block-setattr-bylist
        (setq apnum:Num (+ apnum:Num apnum:Inc))
      ) ;_ end of while
    )                                             ; end progn
  )                                               ; end if
  (setvar "ATTDIA" att)
  (setvar "ATTREQ" attr)
  (princ)
) ;_ end of defun

Перенумерация с выравниванием методом тыка. Нужно указывать на атрибут, текст, размер, мтекст

Код:
[Выделить все] 
(defun c:renumA (/ oldPref oldSuf oldStart curText curStr vlaObj keepText ss)
 ;;;Routine for Renumbering
;;;Realization {Smirnoff} aka ASMI
;;;http://www.autocad.ru/cgi-bin/f1/board.cgi?t=30394Ae
;;;http://www.caduser.ru/cgi-bin/f1/board.cgi?t=29829Am
;;;http://www.autocad.ru/cgi-bin/f1/board.cgi?t=21807yD
;;;Edition 23.10.2006 Vladimir Azarko (VVA)
;;;http://www.autocad.ru/cgi-bin/f1/board.cgi?t=30394Ae
;;;Edition 15.17.2009 Vladimir Azarko (VVA)
;;;http://www.cadtutor.net/forum/showthread.php?p=253543
;;;Edit 14.11.2012 Vladimir Azarko (VVA)
;;;http://forum.dwg.ru/showthread.php?p=511208#post511208  
(vl-load-com)
(defun TTC_Paste(pasteStr keepText / nslLst vlaObj)
(if (setq nslLst(nentsel "\nPaste text <exit> >>"))
(progn
  (cond
((and (= 4(length nslLst))
 (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object (cdr(assoc -1(entget(car(last nslLst)))))))
(setq oldStat (vla-get-Measurement vlaObj))
(if keepText
 (if (= (vla-get-TextOverride vlaObj) "")
 (setq pasteStr (strcat pasteStr (rtos oldStat (vla-get-UnitsFormat vlaObj) (vla-get-PrimaryUnitsPrecision vlaObj))))
 (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj)))))
(if (vl-catch-all-error-p(vl-catch-all-apply 'vla-put-TextOverride(list vlaObj pasteStr)))
 (princ "\n Can't paste. Object may be on locked layer. "))); end condition #1
((and (= 4(length nslLst))
(= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. ")(entupd (car(last nslLst))))); end condition # 2
((and (= 4(length nslLst))
 (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(princ "\nCan't paste to block's DText or MText. ")); end condition #3
((and (= 2(length nslLst))
(member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "MULTILEADER" "ATTRIB" "ATTDEF"))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. "))); end condition #4
(T (princ "\nCan't paste. Invalid object. ")); end condition #5
); end cond
T); end progn
nil); end if
);_TTC_PASTE
(setq aDoc(vla-get-ActiveDocument(vlax-get-acad-object)))
(vla-StartUndoMark aDoc)
(if(not rnm:Pref)(setq rnm:Pref ""))(if(not rnm:Suf)(setq rnm:Suf ""))
(if(not rnm:Start)(setq rnm:Start 1))
(if(not num:Alig)(setq num:Alig "1"))
(setq oldPref rnm:Pref oldSuf rnm:Suf); end setq
(setq rnm:Pref (getstring T
		 (strcat "\nType prefix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <" rnm:Pref "> :")))
(if(= "" rnm:Pref)(setq rnm:Pref oldPref))(if(= " " rnm:Pref)(setq rnm:Pref ""))
(setq rnm:Suf (getstring T
                (strcat "\nType suffix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"rnm:Suf"> :")))
(if(= "" rnm:Suf)(setq rnm:Suf oldSuf))(if(= " " rnm:Suf)(setq rnm:Suf ""))
(setq  oldStart num:Alig)
(initget "1 10 100 1000 10000 100000")
(setq num:Alig 
    (GETKWORD 
      (strcat "\nSpecify alignment of number [1/10/100/1000/10000/100000] <"num:Alig">: ")))
  (if(null num:Alig)(setq num:Alig oldStart))
(setq  oldStart rnm:Start rnm:Start (getint (strcat "\nEnter start number <"
(itoa rnm:Start)">: ")))
(if(null rnm:Start)(setq rnm:Start oldStart))
(initget "Yes No _Yes No")
(setq keepText (not (= "No" (getkword "\nkeep contents of the text [Yes/No] <Yes>:"))))
(setq rnm:Start (1- rnm:Start))
(while
  (progn
  (setq oldStart (itoa (setq rnm:Start(1+ rnm:Start))))
  (while (<= (strlen oldStart)(1- (strlen num:Alig)))
    (setq oldStart (strcat "0" oldStart)))  
  (TTC_Paste (setq curStr(strcat rnm:Pref oldStart rnm:Suf)) keepText)))
(vla-EndUndoMark aDoc)(princ))

PS 2017-06-30
Большая часть нумераторов собраны в FAQ #21 - Как последовательно пронумеровать в чертеже числа?
__________________
Как использовать код на Лиспе читаем здесь
Последний раз редактировалось VVA, 30.06.2017 в 17:07. Причина: В renumA добавлен мультилидер
VVA вне форума  
 
Автор темы   Непрочитано 26.01.2010, 20:47
#9
superkot007


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

VVA
Добрый человек, как же я благодарен за ТАКОЕ!!!

Немного не в тему:
 А можно как-нибудь организовать обновление атрибутов блоков из данных таблицы (acad или excel)? Было бы просто шикарно...

А для работы с динамическими блоками (по тем же lisp-ам, что выше) ЭТО можно куда-нибудь "прикрутить"?
Код:
[Выделить все] 
;;local defuns
;;==================================================*===;;
(defun  getatts   (obj / attr_list)
  (setq   attr_list
    (mapcar
       (function
        (lambda (att)
          (cons  (vla-get-tagstring att) (vla-get-textstring att))
          )
         )
      (vlax-invoke obj 'Getattributes)
      )
   )
  )
;;==================================================*===;;
(defun  getroperty  (blk / props)
  (setq   props (vlax-safearray->list
      (variant-value
        (vla-getdynamicblockproperties  blk))))
  (mapcar (function (lambda (x)
            (vla-get-propertyname  X)))
     props)
  )
;;==================================================*===;;
(defun  getvalue    (blk prop_name)
  (variant-value
    (vla-get-value
      (car
   (vl-remove-if-not
     (function  (lambda (x)
            (eq prop_name (vla-get-propertyname x))))
     (vlax-safearray->list
       (variant-value
         (vla-getdynamicblockproperties  blk)))))))
  )
;;==========================main  part========================;;
(vl-load-com)
(defun C:test  (/  atts blkref data dps dyninfo value)
  (if
    (setq blkref  (vlax-ename->vla-object
         (car (entsel  "\n  >>  Выбрать блок  >>"))))
     (progn
       (if  (eq :vlax-true (vla-get-hasattributes blkref))
    (progn
       (setq atts (getatts blkref))
      (princ "\nАтрибуты:")
       (princ atts)
      (princ "\n")
      )
    (princ "\nБлок не  имеет атрибутов")
    )
       (if (eq :vlax-true  (vla-get-isdynamicblock blkref))
    (progn
      (setq dps  (getroperty blkref))
      (foreach itm    dps
        (setq value  (getvalue blkref itm))
        (if (= (type value) 'SAFEARRAY)
           (setq value (vlax-safearray->list value)))
        (setq data  (cons itm value))
        (setq dyninfo (cons data dyninfo)))
       (princ "\nДин. свойства:")
      (princ dyninfo)
      (princ  "\n")
      )
    (princ "\nБлок не динамический")
    )
        )
     (alert "ничего не выбрано\nПовторите...")
     )
  (princ)
  )
http://www.caduser.ru/forum/index.ph...D=23&TID=42340
Последний раз редактировалось superkot007, 26.01.2010 в 22:47.
superkot007 вне форума  
 
Непрочитано 18.05.2010, 12:50
#10
Redya


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

Offtop: Уже пол часа не могу разобраться. А как мне сделать чтобы без префиксов было и суффиксов? Натуральный ряд просто. Пробелы он не воспринимает.
Всё, разобрался.
Последний раз редактировалось Redya, 19.05.2010 в 11:57.
Redya вне форума  
 
Автор темы   Непрочитано 21.05.2010, 01:59
#11
superkot007


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

Например, так "квадратиками"
Код:
[Выделить все] 
(defun c:piles (/ adoc rec_size pt_lst txt_lst blk_name blk_def ent att pt space
                num)
  (vl-load-com)
  (setq adoc     (vla-get-activedocument (vlax-get-acad-object))
        txt_lst  (textbox (list (cons 0 "TEXT")
                                (cons 10 '(0. 0. 0.))
                                (cons 40 3.0)
                                (cons 1 "500")
                                ) ;_ end of list
                          ) ;_ end of textbox
        rec_size (* 1.1
                    (apply 'max
                           (mapcar '(lambda (a b) (abs (- a b)))
                                   (car txt_lst)
                                   (cadr txt_lst)
                                   ) ;_ end of mapcar
                           ) ;_ end of apply
                    ) ;_ end of *
        pt_lst   (vlax-make-variant
                   (vlax-safearray-fill
                     (vlax-make-safearray
                       vlax-vbdouble
                       (cons 0 7)
                       ) ;_ end of vlax-make-safearray
                     (list (- (/ rec_size 2.0))
                           (- (/ rec_size 2.0))
                           (/ rec_size 2.0)
                           (- (/ rec_size 2.0))
                           (/ rec_size 2.0)
                           (/ rec_size 2.0)
                           (- (/ rec_size 2.0))
                           (/ rec_size 2.0)
                           ) ;_ end of list
                     ) ;_ end of vlax-safearray-fill
                   ) ;_ end of vlax-make-variant
        blk_name "PileNum"
        ) ;_ end of setq
  (if (not (tblobjname "block" blk_name))
    (progn
      (setq blk_def (vla-add (vla-get-blocks adoc)
                             (vlax-3d-point '(0. 0. 0.))
                             blk_name
                             ) ;_ end of vla-add
            ent     (vla-addlightweightpolyline blk_def pt_lst)
            att     (vla-addattribute
                      blk_def
                      3.0
                      acattributemodenormal
                      "Номер"
                      (vlax-3d-point '(0. 0. 0.))
                      "AttPileNum"
                      ""
                      ) ;_ end of vla-addattribute
            ) ;_ end of setq
      (vlax-for sub blk_def
        (vla-put-layer sub "0")
        (vla-put-lineweight sub aclnwtbyblock)
        (vla-put-linetype sub "byblock")
        (vla-put-color sub 0)
        (vla-put-normal sub (vlax-3d-point '(0. 0. 1.)))
        ) ;_ end of vlax-for
      (vla-put-coordinates ent pt_lst)
      (vla-put-closed ent :vlax-true)
      (vla-put-alignment att acalignmentmiddlecenter)
      (vla-put-textalignmentpoint att (vlax-3d-point '(0. 0. 0.)))
      (vla-put-insertionpoint att (vlax-3d-point '(0. 0. 0.)))
      ) ;_ end of progn
    ) ;_ end of if
  (vla-startundomark adoc)
  (setq space (if (and (zerop (vla-get-activespace adoc))
                       (= :vlax-false (vla-get-mspace adoc))
                       ) ;_ end of and
                (vla-get-paperspace adoc)
                (vla-get-modelspace adoc)
                ) ;_ end of if
        num   (cond
                ((= (type (setq num (vl-catch-all-apply
                                      '(lambda () (getint "\nНачальное значение <1> : "))
                                      ) ;_ end of vl-catch-all-apply
                                ) ;_ end of setq
                          ) ;_ end of type
                    'int
                    ) ;_ end of =
                 (1- num)
                 )
                (t 0)
                ) ;_ end of cond
        ) ;_ end of setq
  (while
    (= (type (setq
               pt (vl-catch-all-apply
                    '(lambda () (getpoint "\nУкажите точку вставки <Отмена> : "))
                    ) ;_ end of vl-catch-all-apply
               ) ;_ end of setq
             ) ;_ end of type
       'list
       ) ;_ end of =
     (setq ent (vla-insertblock space (vlax-3d-point pt) blk_name 1. 1. 1. 0.))
     (vla-put-textstring
       (car (vlax-safearray->list (vlax-variant-value (vla-getattributes ent))))
       (itoa (setq num (1+ num)))
       ) ;_ end of vla-put-TextString
     ) ;_ end of while
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun
или так
Код:
[Выделить все] 
(defun c:num (/ oldPref oldSuf oldStart curStr newNum
           actDoc actSp oldEcho oldSize *error*)
  (defun *error* (msg)
    (setvar "CMDECHO" oldEcho)
    (princ)
    ); end *error*
  (vl-load-com)
  (if(not num:Size)(setq num:Size(getvar "DIMTXT")))
  (if(not num:Pref)(setq num:Pref ""))
  (if(not num:Suf)(setq num:Suf ""))
  (if(not num:Num)(setq num:Num 1))
  (setq oldPref num:Pref
        oldSuf num:Suf
        oldStart num:Num
   oldSize num:Size
   actDoc(vla-get-ActiveDocument
      (vlax-get-acad-object))
   oldEcho(getvar "CMDECHO")
   ); end setq
  (setvar "CMDECHO" 0)
  (if(= (vla-get-ActiveSpace actDoc) 1)
    (setq actSp(vla-get-ModelSpace actDoc))
    (setq actSp(vla-get-PaperSpace actDoc))
    ); end setq
  (setq num:Size
    (getreal
      (strcat "\nSpecify text size <"(rtos num:Size)">: ")))
  (if(null num:Size)(setq num:Size oldSize))
  (setq num:Pref
    (getstring T
      (strcat "\nType prefix: <"num:Pref">: ")))
  (if(= "" num:Pref)(setq num:Pref oldPref))
  (if(= " " num:Pref)(setq num:Pref ""))
  (setq num:Suf
    (getstring T
      (strcat "\nType suffix: <"num:Suf">: ")))
  (if(= "" num:Suf)(setq num:Suf oldSuf))
  (if(= " " num:Suf)(setq num:Suf ""))
  (setq num:Num
    (getint
      (strcat "\nEnter start number <"(itoa num:Num)">: ")))
  (if(null num:Num)(setq num:Num oldStart))
(while T
  (setq curStr(strcat num:Pref(itoa num:Num)num:Suf)
        newNum(vla-AddText actSp
        curStr (vlax-3d-point
       '(0.0 0.0 0.0)) num:Size))
  (vla-put-Alignment newNum acAlignmentMiddleCenter)
  (command "_.copybase"(trans '(0.0 0.0 0.0)0 1)(entlast)"")
  (command "_.erase" (entlast) "")
  (command "_.pasteclip" pause)
    (setq num:Num(1+ num:Num))
  ); end while
  (princ)
  ); end of c:num
(defun c:renum (/ oldPref oldSuf oldStart curText curStr)
  (vl-load-com)
  (if(not rnm:Pref)(setq rnm:Pref ""))
  (if(not rnm:Suf)(setq rnm:Suf ""))
  (if(not rnm:Start)(setq rnm:Start 1))
  (setq oldPref rnm:Pref
        oldSuf rnm:Suf
        oldStart rnm:Start); end setq
  (setq rnm:Pref
    (getstring T
      (strcat "\nType prefix: <"rnm:Pref">: ")))
  (if(= "" rnm:Pref)(setq rnm:Pref oldPref))
  (if(= " " rnm:Pref)(setq rnm:Pref ""))
  (setq rnm:Suf
    (getstring T
      (strcat "\nType suffix: <"rnm:Suf">: ")))
  (if(= "" rnm:Suf)(setq rnm:Suf oldSuf))
  (if(= " " rnm:Suf)(setq rnm:Suf ""))
  (setq rnm:Start
    (getint
      (strcat "\nEnter start number <"
         (itoa rnm:Start)">: ")))
  (if(null rnm:Start)(setq rnm:Start oldStart))
(while T
  (setq curStr(strcat rnm:Pref(itoa rnm:Start)rnm:Suf))
    (setq curText
      (car
        (nentsel "\nSelect DText/MText/Attribute or Esc to Quit ")))
  (if
    (and
      curText
      (member(cdr(assoc 0(entget curText))) '("TEXT" "MTEXT" "ATTRIB"))
      ); end and
    (progn
    (vla-put-TextString
      (vlax-ename->vla-object curText)curStr)
    (setq rnm:Start(1+ rnm:Start))
    ); end progn
    (princ "\nThis is not DText or MText! ")
    ); end if
  ); end while
  (princ)
  ); end of c:renum
superkot007 вне форума  
 
Непрочитано 21.05.2010, 08:29
#12
DushMan


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

Подскажите, в чертеже более 200 блоков с атрибутами, это все длинна кабеля. Можно ли извлечь из этих блоков-атрибутов марку кабеля и длинну и вставить все это в Excel? пример строки атрибута: МКЭШВнг 2х2х1,0 200м .
DushMan вне форума  
 
Непрочитано 01.07.2010, 11:42
#13
mwm


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

Цитата:
выдал "Блок не найден"
Что-то я от этой проблемы так и не могу избавиться. Пишет блок не найден и все. Может я блоки неправильные делаю?
mwm вне форума  
 
Непрочитано 01.07.2010, 12:17
#14
Олег (jr.)

специалист по околачиванию грушевых деревьев
 
Регистрация: 14.09.2004
Pietari, Venäjä
Сообщений: 811

Цитата:
Сообщение от mwm Посмотреть сообщение
Что-то я от этой проблемы так и не могу избавиться. Пишет блок не найден и все. Может я блоки неправильные делаю?
Динамический блок?

~'J'~
Олег (jr.) вне форума  
 
Непрочитано 01.07.2010, 13:41
#15
mwm


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

честно говоря я не знаю динамический или нет. выделяю примитивы, которые должны составлять блок и при перетаскивании вставляю как блок, далее редактирую в редакторе блоков.
mwm вне форума  
 
Непрочитано 01.07.2010, 15:44
#16
Олег (jr.)

специалист по околачиванию грушевых деревьев
 
Регистрация: 14.09.2004
Pietari, Venäjä
Сообщений: 811

Цитата:
Сообщение от mwm Посмотреть сообщение
далее редактирую в редакторе блоков.
Если выбирать блоки по-одному после того как они вставлены то это
должно работать как для обычных так и динамических
(наваял по-бырому, без особой проверки)
Код:
[Выделить все] 
(vl-load-com)

;;R.K. McSwain
(defun getEffectiveName (ent)
  (setq obj (vlax-ename->vla-object ent))
  (vlax-get obj 'EffectiveName)
)

(defun restore_layers  (layer_list)
    (foreach lay  layer_list
      (vla-put-lock (vla-item
		      (vla-get-layers
			(vla-get-activedocument
			  (vlax-get-acad-object))) lay)
	:vlax-false
	)
      )
    (princ)
    )

;; main programm
(defun C:BNUM (/ *error* adoc ans blkobj elist ent layer layer_list layer_obj
	         blkname new_value next next_data num pfx sfx ss tag)
;; error routine by CAB
  (defun *error*  (msg)			  ; create standard error handler
      (cond ((not msg))				  ; normal exit, no error
	    ((member msg '("Function cancelled" "quit / exit abort"))) ; escape
	    ((princ (strcat "\nError: " msg))	  ; display fatal error
	     )
	    )	

      (setvar "cmdecho" 1)                        ; restore environments

      (if layer_list (restore_layers layer_list)) ; restore layer state
      (command "._undo" "_end")
      (command)
      )


  (command "._undo" "_begin")
  
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  
  (initget 1 "Block Text")
  (setq ans (getkword "\nChoose desired entity type [Block/Text]: "))
  (setq num (getint "\nInitial number: "))
  (if (not num)(setq num 1))
  (setq pfx (getstring "\nSpecify Prefix (or press Enter to discard prefix): "))
  (setq sfx (getstring "\nSpecify Suffix (or press Enter to discard suffix): "))
  (if (eq "Block" ans)
    (progn
      (while (not
	     (or
	     (eq (setq blkname (getstring "\nSpecify Block Name: ")) "")
	           (tblsearch "BLOCK" blkname)
	     )
	   )
    (princ "\nBlock does not exists")
    )
    (while (eq "" (setq tag (strcase (getstring nil "\nSpecify Desired Tag: ")))))
    (setq filter (list 
			       (cons -4 "<and")
			       (cons 0 "INSERT")
			       (cons 66 1)
			       (cons 410 (getvar "CTAB"))
			       (cons 2 (strcat "`*U*," blkname))
			       (cons -4 "and>"))))
    (setq filter (list 
    			       (cons -4 "<and")
			       (cons 0 "*TEXT")
			       (cons 410 (getvar "CTAB"))
			       (cons -4 "and>")))
			 )

  
  (while (setq ss (ssget "+.:S:E"  filter)) 
  
   (setq ent (ssname ss 0))
(if (eq "Text" ans)
(progn
       (setq elist (entget ent))
       (entmod (subst (cons 1 (strcat pfx (rtos num 2 0) sfx))
		      (assoc 1 elist)elist))
       (entupd ent)
       (setq num (1+ num))
       )
  (progn
   
    (if (eq blkname (getEffectiveName ent))
      (progn
	
	(setq next ent
	      blkobj (vlax-ename->vla-object ent)
	      layer (vla-get-layer blkobj)
	      layer_obj (vla-item (vla-get-layers adoc) layer)
	      )
	(if (and (eq :vlax-true (vlax-get-property layer_obj 'Lock)) 
		 (not (member layer layer_list)))
	  (progn
	  (setq layer_list (cons layer layer_list))
	  (vlax-put-property layer_obj 'Lock :vlax-false)))
	
      (while (not (eq "SEQEND" (cdr (assoc 0 (entget next)))))
	(setq next (entnext next))
	(setq next_data (entget next))
	(if (eq "ATTRIB" (cdr (assoc 0 next_data)))
	  (progn	
	      (if (eq (cdr (assoc 2 next_data)) tag)
	       (progn
	       (setq new_value (strcat pfx (rtos num 2 0) sfx))
	       (entmod (subst (cons 1 new_value) (assoc 1 next_data) next_data))
	       (entupd next)
	    (entupd ent)
	  )
		(setq next nil)
    )
	)
    
   )
    )
    (setq num (1+ num))
    )
      )
   )
   )
      )
  (vla-regen adoc acActiveViewport)

  (princ)
)
(princ "\n  >>  Start command with BNUM  <<")
(prin1)
Добавлена возможность работы с текстами/мтекстами

~'J'~
Последний раз редактировалось Олег (jr.), 02.07.2010 в 23:15. Причина: добавлены дополнительные опции выбора
Олег (jr.) вне форума  
 
Непрочитано 01.07.2010, 20:39
#17
mwm


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

Огромное спасибо!!!
Проблема была в том, что я не делал _regenall из-за этого блоки не выбирались

перенумерация через выбор по имени не заработала(выдает ; ошибка: неверная строка режима ssget) но почему то натолкнула на _regenall
mwm вне форума  
 
Непрочитано 01.07.2010, 21:06
#18
Олег (jr.)

специалист по околачиванию грушевых деревьев
 
Регистрация: 14.09.2004
Pietari, Venäjä
Сообщений: 811

Цитата:
Сообщение от mwm Посмотреть сообщение
Огромное спасибо!!!
Проблема была в том, что я не делал _regenall из-за этого блоки не выбирались

перенумерация через выбор по имени не заработала(выдает ; ошибка: неверная строка режима ssget) но почему то натолкнула на _regenall
Какая версия Автокада?
Олег (jr.) вне форума  
 
Непрочитано 02.07.2010, 23:16
#19
Олег (jr.)

специалист по околачиванию грушевых деревьев
 
Регистрация: 14.09.2004
Pietari, Venäjä
Сообщений: 811

Обновил код выше
Попробуй теперь

~'J'~
Олег (jr.) вне форума  
 
Непрочитано 22.11.2010, 15:35 при удалении блока, нумерация сдвигается
#20
zip13


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

пользуюсь командой apnumA. Расставляю блоки на чертеже, атрибут меняет свое значение 1...2..3 итд как сделать так, чтобы при удалении одного блока нумерация выше этого блока сдвигалась на -1 (восстанавливалась) и при вставке следущего блока его атрибут становился "общее кол-во этих блоков"+1
zip13 вне форума  
 
Непрочитано 22.11.2010, 16:57
#21
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996

Цитата:
Сообщение от zip13 Посмотреть сообщение
пользуюсь командой apnumA.
Пользуйся BinCA из #8. Это дальнейшее развитие apnumA. Она в том числе делает и это:

Цитата:
Сообщение от zip13 Посмотреть сообщение
и при вставке следущего блока его атрибут становился "общее кол-во этих блоков"+1
По поводу
Цитата:
Сообщение от zip13 Посмотреть сообщение
чтобы при удалении одного блока нумерация выше этого блока сдвигалась на -1
наверное нужно писать реактор. Но на это у меня пока нет времени.
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 10.12.2010, 15:46
#22
Iogan


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

Пожалуйста, помогите "чайнику"
Проблема - блоки на чертеже расставлены в порядке: слева направо, сверху вниз. У блоков есть атрибут "номер". Необходимо автоматически пронумеровать блоки последовательно, примерно так:
1,2,3,4,
5,6,7,
8,9...
Может у кого есть готовое решение? Буду премного благодарен!!!
Iogan вне форума  
 
Непрочитано 10.12.2010, 23:10
#23
Дима_

Продуман
 
Регистрация: 22.02.2007
Питер
Сообщений: 2,839

не проверял, запускать командой test
Код:
[Выделить все] 
(vl-load-com)
(defun cod (cd obj) ; возращает код cd примитива obj.
  (if (and obj (= (type obj) 'ename))
      (cdr (assoc cd (entget obj)))));end of cod

(defun c:test ()
  ((lambda (f-get-atr-on-name f-rec lst)
     ((lambda (lst-n)
        (f-rec 1 lst-n)
        (mapcar '(lambda (atr) (vla-put-textstring atr (rtos (length lst-n)))) (f-get-atr-on-name "КОЛИЧЕСТВО" lst)))
      (f-get-atr-on-name "НОМЕР" lst)))
   (lambda (name lst)
     (vl-remove
      nil
      (mapcar '(lambda (obj)
                 (car (vl-remove-if-not '(lambda (atr) (= (vla-get-tagstring atr) name))
                                        (vlax-safearray->list (vlax-variant-value (vla-getattributes obj))))))
              lst)))
   (lambda (x lst-atr)
     (if lst-atr (progn
                  (vla-put-textstring (car lst-atr) (rtos x))
                  (f-rec (1+ x) (cdr lst-atr)))))
  (mapcar 'vlax-ename->vla-object
          (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget (list (cons 0 "insert") (cons 66 1))))))
                   '(lambda (ent1 ent2)
                      (if (> (cadr (cod 10 ent1))
                             (cadr (cod 10 ent2)))
                          T
                          (if (equal (cadr (cod 10 ent1))
                                     (cadr (cod 10 ent2))
                                     0.00001)
                              (< (car (cod 10 ent1))
                                 (car (cod 10 ent2))))))))))
__________________
Когда в руках молоток все вокруг кажется гвоздями.
Последний раз редактировалось Дима_, 17.12.2010 в 15:14.
Дима_ вне форума  
 
Непрочитано 10.12.2010, 23:15
#24
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996

можно ли автоматизировать нумерацию блоков
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 13.12.2010, 11:39
#25
Iogan


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

Спасибо !!!
Очень выручил
Iogan вне форума  
 
Непрочитано 17.12.2010, 14:09
#26
Iogan


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

Уважаемый Дима, ещё раз спасибо, все работает отлично,
а теперь бы записать кол-во атрибутов "НОМЕР" в атрибут "КОЛИЧЕСТВО"
былоб вообще чудесно.
Перелопатил всю прогу, но сам не смог это выполнить.
А то на большом чертеже приходится его двигать-зуммировать, чтоб найти последний "НОМЕР"

Как говорится, "Аппетит приходит во время еды"
Iogan вне форума  
 
Непрочитано 17.12.2010, 15:15
#27
Дима_

Продуман
 
Регистрация: 22.02.2007
Питер
Сообщений: 2,839

переправил в п.23
__________________
Когда в руках молоток все вокруг кажется гвоздями.
Дима_ вне форума  
 
Непрочитано 07.02.2016, 11:06
#28
sfynks


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

Прошло 5 лет...
VVA, pickblocknum из #8
Почему нумерация атрибутов блока происходит справа - налево? т.е. не 1-2-3-4-5... а 5-4-3-2-1
Можно как то реализовать выбор направления нумерации?
sfynks вне форума  
 
Непрочитано 08.02.2016, 14:56
1 | #29
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996

Добавлена сортировка по точке вставки блоков слева-направо, снизу-вверх
Код:
[Выделить все] 
(defun c:pickblocknumS (/         oldStart  oldPref   oldSuf
                       oldEcho   oldInc    oldSize   oldBlock
                       temBl     *error*   att       attr
                       apnum:tag pt        el test_list fpt
                      )
;;; 2016-02-08 Добавлена сортировка по точке вставки блоков слева-направо, снизу-вверх  
;;;Новая версия Если в блоке несколько атрибутов, то выбирается какой нужно вставить
;;;http://forum.dwg.ru/showthread.php?p=1500379#post1500379

;_==== Local functions ============
  (vl-load-com)
  (defun *error* (msg)
    (setvar "CMDECHO" oldEcho)
    (setvar "ATTDIA" att)
    (setvar "ATTREQ" attr)
    (princ)
  );_ end *error*
  (defun mydcl (zagl info-list / fl ret dcl_id)
    (if (null zagl)
      (setq zagl "Select")
    ) ;_ end of if
    (setq fl (vl-filename-mktemp "mip" nil ".dcl"))
    (setq ret (open fl "w"))
    (mapcar
      '(lambda (x) (write-line x ret))
      (list "mip_msg : dialog { "
            (strcat "label=\"" zagl "\";")
            " :list_box {"
            "alignment=top ;"
            "width=51 ;"
            (if (> (length info-list) 26)
              "height= 26 ;"
              (strcat "height= " (itoa (+ 3 (length info-list))) ";")
            ) ;_ end of if
            "is_tab_stop = false ;"
            "key = \"info\";}"
            "ok_cancel;}"
      ) ;_ end of list
    ) ;_ end of mapcar
    (setq ret (close ret))
    (if (and (not (minusp (setq dcl_id (load_dialog fl))))
             (new_dialog "mip_msg" dcl_id)
        ) ;_ end of and
      (progn
        (start_list "info")
        (mapcar 'add_list info-list)
        (end_list)
        (set_tile "info" "0")
        (setq ret (car info-list))
        (action_tile
          "info"
          "(setq ret (nth (atoi $value) info-list))"
        ) ;_ end of action_tile
        (action_tile
          "cancel"
          "(progn(setq ret nil)(done_dialog 0))"
        ) ;_ end of action_tile
        (action_tile "accept" "(done_dialog 1)")
        (start_dialog)
      ) ;_ end of progn
    ) ;_ end of if
    (unload_dialog dcl_id)
    (vl-file-delete fl)
    ret
  ) ;_ end of defun
  (defun mip-conv-to-str (dat)
    (cond ((= (type dat) 'INT) (setq dat (itoa dat)))
          ((= (type dat) 'REAL) (setq dat (rtos dat 2 12)))
          ((null dat) (setq dat ""))
          (t (setq dat (vl-princ-to-string dat)))
    ) ;_ end of cond
  ) ;_ end of defun
  ;; obj - Ename or Vla object of block
  ;; att_list - list ((Tag_Name1 . Value1)(Tag_Name2 . Value2) ...)
  ;;                 Tag_Name - string
  ;;                    Value - string
  (defun mip-block-setattr-bylist (obj att_list / txt lst)
    (if (= (type obj) 'ENAME)
      (setq obj (vlax-ename->vla-object obj))
    ) ;_ end of if
    (setq
      att_list (mapcar '(lambda (x)
                          (cons (strcase (mip-conv-to-str (car x)))
                                (mip-conv-to-str (cdr x))
                          ) ;_ end of cons
                        ) ;_ end of lambda
                       att_list
               ) ;_ end of mapcar
    ) ;_ end of setq
    (if (and obj
             (not (vlax-erased-p obj))
             (= (vla-get-objectname obj) "AcDbBlockReference")
             (eq :vlax-true (vla-get-hasattributes obj))
             (vlax-property-available-p obj 'Hasattributes)
             (vlax-write-enabled-p obj)
        ) ;_ end of and
      (vl-catch-all-apply
        (function
          (lambda ()
            (foreach at (vlax-invoke obj 'Getattributes)
              (if (setq lst
                         (assoc (strcase (vla-get-tagstring at)) att_list)
                  ) ;_ end of setq
                (vla-put-textstring at (cdr lst))
              ) ;_ end of if
            ) ;_ end of foreach
          ) ;_ end of lambda
        ) ;_ end of function
      ) ;_ end of vl-catch-all-apply
    ) ;_ end of if
  ) ;_ end of defun

  (defun get-all-atts (obj)
;;;Use (get-all-atts (car(entsel "\nSelect block:")))
;;;Returs list  (("TAG1" . "Value1")("TAG2" . "Value2") ...)
    (if (= (type obj) 'ENAME)
      (setq obj (vlax-ename->vla-object obj))
    ) ;_ end of if
    (if (and obj
             (vlax-property-available-p obj 'Hasattributes)
             (eq :vlax-true (vla-get-hasattributes obj))
        ) ;_ end of and
      (vl-catch-all-apply
        (function
          (lambda ()
            (mapcar (function (lambda (x)
                                (cons (vla-get-tagstring x)
                                      (vla-get-textstring x)
                                ) ;_ end of cons
                              ) ;_ end of lambda
                    ) ;_ end of function
                    (append (vlax-invoke obj 'Getattributes)
                            (vlax-invoke obj 'Getconstantattributes)
                    ) ;_ end of append
            ) ;_ end of mapcar
          ) ;_ end of lambda
        ) ;_ end of function
      ) ;_ end of vl-catch-all-apply
    ) ;_ end of if
  ) ;_ end of defun
  (defun rec-pat (str temp)
    (cond
      ((= str "")
       (if (/= temp "")
         (list temp)
       ) ;_ end of if
      )
      ((wcmatch (substr str 1 1) "[1234567890.]")
       (rec-pat (substr str 2) (strcat temp (substr str 1 1)))
      )
      (t
       (if (/= temp "")
         (cons temp (rec-pat str ""))
         (rec-pat (substr str 2) "")
       ) ;_ end of if
      )
    ) ;_ end of cond
  ) ;_ end of defun


                                                  ;==== Local functions END ============

  (if (not apnum:Size)
    (setq apnum:Size 1.0)
  ) ;_ end of if
  (if (not apnum:Num)
    (setq apnum:Num 1)
  ) ;_ end of if
  (if (not apnum:Inc)
    (setq apnum:Inc 1)
  ) ;_ end of if
  (if (not apnum:Pref)
    (setq apnum:Pref "")
  ) ;_ end of if
  (if (not apnum:Suf)
    (setq apnum:Suf "")
  ) ;_ end of if
  (setq oldStart    apnum:Num
        oldSize     apnum:Size
        oldInc      apnum:Inc
        oldPref     apnum:Pref
        oldSuf      apnum:Suf
        apnum:Block (mip-conv-to-str apnum:Block)
        apnum:tag   (mip-conv-to-str apnum:tag)
        oldEcho     (getvar "CMDECHO")
        att         (getvar "ATTDIA")
        attr        (getvar "ATTREQ")
  )                                               ; end setq
  (setvar "ATTDIA" 0)
  (setvar "ATTREQ" 0)
  (setvar "CMDECHO" 0)
  (setq apnum:Pref
         (getstring
           t
           (strcat
             "\nType prefix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"
             apnum:Pref
             "> :"
           ) ;_ end of strcat
         ) ;_ end of getstring
  ) ;_ end of setq
  (if (= "" apnum:Pref)
    (setq apnum:Pref oldPref)
  ) ;_ end of if
  (if (= " " apnum:Pref)
    (setq apnum:Pref "")
  ) ;_ end of if
  (setq apnum:Suf
         (getstring
           t
           (strcat
             "\nType suffix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"
             apnum:Suf
             "> :"
           ) ;_ end of strcat
         ) ;_ end of getstring
  ) ;_ end of setq
  (if (= "" apnum:Suf)
    (setq apnum:Suf oldSuf)
  ) ;_ end of if
  (if (= " " apnum:Suf)
    (setq apnum:Suf "")
  ) ;_ end of if
  (if apnum:Block
    (setq oldBlock apnum:Block)
  ) ;_ end of if
  (setq temBl
         (entsel (strcat "\nSelect block <"
                         (if apnum:Block
                           apnum:Block
                           "not difined"
                         ) ;_ end of if
                         "> > "
                 ) ;_ end of strcat
         ) ;_ end of entsel
  )                                               ; end setq
  (cond
    ((or (and tembl
              (= 1 (cdr (assoc 66 (entget (car temBl)))))
              (= "INSERT" (cdr (assoc 0 (entget (car temBl)))))
         ) ;_ end of and
         (and apnum:Block
              (setq tembl (tblobjname "BLOCK" apnum:Block))
              (setq tembl (list tembl))
         ) ;_ end of and
     ) ;_ end of or
     (setq apnum:Block (cdr (assoc 2 (entget (car temBl)))))
     ((lambda (/ lst e1 ed ss i)
        (setq e1 (entnext (car temBl)))
        (while (and e1
                    (wcmatch (cdr (assoc 0 (setq ed (entget e1))))
                             "ATTRIB,ATTDEF"
                    ) ;_ end of wcmatch
               ) ;_ End of AND
          (setq lst (cons (cdr (assoc 2 ed)) lst))
          (setq e1 (entnext e1))
        ) ;_ end of while
        (cond ((= 0 (length lst)) (setq apnum:Block nil))
              ((= 1 (length lst)) (setq apnum:tag (car lst)))
              (t
               (setq
                 apnum:tag (mydcl "Select attribute" (acad_strlsort lst))
               ) ;_ end of setq
              )
        ) ;_ end of cond
;;; Максимальный номер берется как максимальное число всех значений атрибутов
;;; Высчитыватся так (допустим значение атрибута   D3SE/0-008A18B3:
;;;        Значение префикса D3SE/0-
;;;        Значение суффикса B3 
;;;         1. Из значения атрибута удаляется префикс и суффикс
;;;                Значение атрибута - 008A18
;;;         2. В значении атрибута выбираются все цифры ("008" "18")
;;;         3. Из них за число атрибута берется число с максимальной последовательностью цифр
;;;                    т.е. 8, а не 18

        (and
          (setq ss nil
                ss (ssget "_X"
                          (list
                            '(0 . "INSERT")
                            (cons 2 apnum:Block)
                            (cons 410 (getvar "CTAB"))
                          ) ;_ end of list
                   ) ;_ end of ssget
          ) ;_ end of setq
          (setq lst nil
                i   '-1
          ) ;_ end of setq
          (progn
            (repeat (sslength ss)
              (setq lst (cons (ssname ss (setq i (1+ i))) lst))
            ) ;_ end of repeat
            lst
          ) ;_ end of progn
          (setq apnum:Num
                 (1+
                   (apply
                     'max
                     (mapcar
                       'atoi
                       (mapcar
                         'mip-conv-to-str
                         (mapcar
                           '(lambda (f / mst)
                              (setq mst
                                     (apply 'max (mapcar 'strlen f))
                              ) ;_ end of setq
                              (car
                                (vl-remove-if-not
                                  '(lambda (f1) (= mst (strlen f1)))
                                  f
                                ) ;_ end of vl-remove-if-not
                              ) ;_ end of car
                            ) ;_ end of lambda
                           (mapcar
                             '(lambda (z) (rec-pat z ""))
                             (mapcar
                               '(lambda (y)
                                  (vl-string-right-trim
                                    (mip-conv-to-str apnum:Suf)
                                    (vl-string-left-trim
                                      apnum:pref
                                      y
                                    ) ;_ end of vl-string-left-trim
                                  ) ;_ end of vl-string-right-trim
                                ) ;_ end of lambda
                               (vl-remove-if
                                 'null
                                 (mapcar
                                   '(lambda (x)
                                      (cdr (assoc (strcase apnum:tag)
                                                  (get-all-atts x)
                                           ) ;_ end of assoc
                                      ) ;_ end of cdr
                                    ) ;_ end of lambda
                                   lst
                                 ) ;_ end of mapcar
                               ) ;_ end of vl-remove-if
                             ) ;_ end of mapcar
                           ) ;_ end of mapcar
                         ) ;_ end of mapcar
                       ) ;_ end of mapcar
                     ) ;_ end of mapcar
                   ) ;_ end of apply
                 ) ;_ end of 1+
          ) ;_ end of setq
        ) ;_and
      ) ;_lambda
     ) ;_lambda
    )                                             ; end condition #2
    ((null (tblsearch "BLOCK" apnum:Block))
     (alert (strcat "Block " apnum:Block " not found"))
     (setq apnum:Block nil)
    )                                             ; end condition #0
    ((and apnum:Block
          (not temBl)
          (tblsearch "BLOCK" apnum:Block)
     ) ;_ end of and
     (setq apnum:Block oldBlock)
    )                                             ; end condition #1

    (t
     (princ "\nBlock not contains attribute! ")
     (setq apnum:Block nil)
    )                                             ; end condition #3
  )                                               ; end cond  
  (setq apnum:Num
         (getint
           (strcat "\nSpecify start number <" (itoa apnum:Num) ">: ")
         ) ;_ end of getint
  ) ;_ end of setq
  (if (null apnum:Num)
    (setq apnum:Num oldStart)
  ) ;_ end of if
  (setq apnum:Inc
         (getint
           (strcat "\nSpecify increment <" (itoa apnum:Inc) ">: ")
         ) ;_ end of getint
  ) ;_ end of setq
  (if (null apnum:Inc)
    (setq apnum:Inc oldInc)
  ) ;_ end of if

  (if (and apnum:Block
           apnum:tag
           (setq
             ss (ssget "_:L" (list '(0 . "INSERT") (cons 2 apnum:Block)))
           ) ;_ end of setq
      ) ;_ end of and
    (progn
      (setq lst nil
                i   '-1
          ) ;_ end of setq
            (repeat (sslength ss)
              (setq lst (cons (ssname ss (setq i (1+ i))) lst))
            ) ;_ end of repeat
            lst
          (setq test_list (mapcar '(lambda (x) (vlax-get (vlax-ename->vla-object x) 'Insertionpoint)) lst)
                fpt (list (1- (apply 'min (mapcar 'car test_list)))(1-(apply 'min (mapcar 'cadr test_list))))
              lst (vl-sort lst '(lambda (e1 e2)
                          (setq e1 (vlax-ename->vla-object e1) e2 (vlax-ename->vla-object e2))              
                          (if (vl-every '(lambda (x) (equal (cadr x) (cadar test_list) 0.1)) test_list) 
                            (< (abs (- (car fpt) (car (vlax-get e1 'Insertionpoint)))) 
                               (abs (- (car fpt) (car (vlax-get e2 'Insertionpoint))))) 
                            (< (abs (- (cadr fpt) (cadr (vlax-get e1 'Insertionpoint)))) 
                               (abs (- (cadr fpt) (cadr (vlax-get e2 'Insertionpoint)))))))))
      (foreach itm lst
        (mip-block-setattr-bylist
          itm
          (list (cons (strcase (mip-conv-to-str apnum:tag))
                      (strcat apnum:Pref (itoa apnum:Num) apnum:Suf)
                ) ;_ end of cons
          ) ;_ end of list
        ) ;_ end of mip-block-setattr-bylist
        (setq apnum:Num (+ apnum:Num apnum:Inc))
        )
    ) ;_ end progn
  ) ;_ end if
  (setvar "ATTDIA" att)
  (setvar "ATTREQ" attr)
  (princ)
) ;_ end of defun
Похожая тема Помогите плиз с программкой по автоматической нумерации
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 08.02.2016, 15:29
#30
sfynks


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

Все работает как надо... Спасибо!!!

----- добавлено через ~3 мин. -----
За ссылку на аналогичную тему спасибо. Поиск по теме ее не находил...
sfynks вне форума  
 
Непрочитано 29.10.2016, 13:56
#31
СерJант

Инженер
 
Регистрация: 12.10.2007
Россия, Энгельс
Сообщений: 27

уважаемый VVA, можно ли усовершенствовать RenumA, что бы он работал не только методом тыка но и рамкой выделения?? Т.е. выделяем слева направо нумеруется в такой же последовательности, выделяем справа налево нумеруется в этой последовательности, ну и сверху вниз и обратно по смыслу... Такое возможно реализовать для текста?

----- добавлено через ~3 мин. -----
есть еще замечательный лисп Num интересует вопрос точку привязки как я понимаю можно изменить тут (vla-put-Alignment newNum acAlignmentMiddleCenter), как ее сделать не "Середина по центру", а "Центр"? Вообще было бы не плохо если бы в программе эту точку привязки можно было настраивать в ручную, например как в опции Центр но с отступом на некую величину от текста, такое возможно?
Последний раз редактировалось СерJант, 29.10.2016 в 14:02.
СерJант вне форума  
 
Непрочитано 30.06.2017, 14:50
#32
allar8


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

Цитата:
Сообщение от VVA Посмотреть сообщение
superkot007, На caduser'e было полно нумераторов. Один из них - binc. Вариант с запросом блока и выбором атрибута:
А она только вставлять может блоки? А можно тоже самое, но с уже существующими на чертеже блоками
allar8 вне форума  
 
Непрочитано 30.06.2017, 17:06
#33
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996

Цитата:
Сообщение от allar8 Посмотреть сообщение
А можно тоже самое, но с уже существующими на чертеже блоками
Это называется перенумерация. Не поленись пройтись по теме (тем более что здесь всего 3 десятка постов).
Приведены как коды, так и ссылки на другие ресурсы
Например в этой теме #8
Все нумераторы собраны в FAQ #21 - Как последовательно пронумеровать в чертеже числа?
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Опять про Lisp-ы... (Помощь чайнику в редактировании)



Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Опять про перепуск арматуры AlfF1 Железобетонные конструкции 52 14.11.2017 08:55
Опять про системные переменные DEL AutoCAD 4 03.11.2006 11:12
опять про Layout... тинатаки AutoCAD 3 13.06.2006 16:22
Опять про XP SP2 Андрей С. AutoCAD 7 16.03.2005 13:15
Опять про исчезающие тулбары Startrek Программирование 2 03.01.2005 16:53

Обратная связь - Вверх