Перейти к содержимому раздела
Форумы CADUser
Информационный портал для профессионалов в области САПР
Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Дерево сообщений Активные темы Темы без ответов
Настройки поиска
Начать новый поиск
Сообщений найдено 11
Команда ApnumA - ApnumAlign
Добавлена возможность "выравнивания" (добивание слева 0) начального номера атрибута. Если выбрать выравнивание 100, то значение атрибута
1 будет записано как 01
2 будет записано как 02
99 будет записано как 99
;;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)
)
В своей работе постоянно приходиться нумеровать большое количество элементов при помощи блока с атрибутом, поэтому взял на вооружение LISP - "apnum". Возможности данного LISPа вполне устраивают, за исключением существенного недостатка - невозможность задавать разрядность числа (0; 00; 000; ...).
Прошу помощи у знающих людей в устранение данного недостатка. И было бы совсем хорошо дополнить данный LISP окном для ввода начальных параметров, которые сейчас нужно вводить в командной строке.
1. ATTDIA = 0 ATTREQ = 0
2. Вставляешь блок.
3. Потом программно изменяешь атрибуты
Я выкладывал здесь https://www.caduser.ru/forum/topic35337.html в посте
> VVA
ф-цию mip-block-setattr-bylist Используй ее.
Как пример смотри BINC по ссылке выше
Для тебя здесь важно
(defun c:binc (/ oldStart oldPref oldSuf oldEcho
oldSize oldBlock temBl *error* att attr apnum:tag pt)
;==== Local functions ============
;;[b]Эта и есть нужная тебе функция [/b]
;; 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))
)
)
)
)
)
)
)
;==== Local functions END ============
....
;;;[b]Это п.1[/b]
(setvar "ATTDIA" 0)(setvar "ATTREQ" 0)
....
;;;[b]Это п.2[/b]
(command "_-insert" apnum:Block "_s" apnum:Size pause "0")
....
;;;[b]Это п.3[/b]
(mip-block-setattr-bylist (entlast)
(list(cons (strcase (mip-conv-to-str apnum:tag))
(strcat apnum:Pref(itoa apnum:Num)apnum:Suf))))
....
(setvar "ATTDIA" att)(setvar "ATTREQ" attr)
....
> KAI
(initget "Yes No ?? ??? _Yes No Yes No") - это скопированный в буфер русский текст на английской раскладке. Должно выглядеть так
(initget "Yes No Да Нет _Yes No Yes No")
[code]
По поводу apnum для 1-го атрибута и инкремента, у меня есть модифицированный вариант BINC
Правда имя блока и имя тага атрибута пока надо прописывать в программе, но можно прикрутить диалог настройки на блок и имя атрибута
Прока прописывать имена нужно здесь
[code]
(setq apnum:Block "BlockName") ;_Впиши имя блока здесь (Enter a name of the block here )
(setq apnum:tag "Nomer") ;_Впиши имя тага атрибута (Enter a tag name of attribute)
[/code]
Текст команды
[code]
(defun c:binc (/ oldStart oldPref oldSuf oldEcho oldInc
oldSize oldBlock temBl *error* att attr apnum:tag pt)
;====================================================================
(setq apnum:Block "BlockName") ;_Впиши имя блока здесь (Enter a name of the block here )
(setq apnum:tag "Nomer") ;_Впиши имя тага атрибута (Enter a tag name of attribute)
;===================================================================
;==== Local functions ============
(defun *error* (msg)(setvar "CMDECHO" oldEcho)(setvar "ATTDIA" att)(setvar "ATTREQ" attr)(princ)); end *error*
(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))
)
)
)
)
)
)
)
;==== 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 ""))
(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 apnum:Block(setq oldBlock apnum:Block))
;;; (setq temBl
;;; (entsel(strcat "\nSelect block <"
;;; (if apnum:Block apnum:Block "not difined") "> > "))); end setq
(cond
((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
((and tembl (= 1 (cdr(assoc 66(entget(car temBl))))))
(setq apnum:Block(cdr(assoc 2(entget(car temBl)))))
); end condition #2
(t
(princ "\nBlock not contains attribute! ")
(setq apnum:Block nil)
); end condition #3
); end cond
(if apnum:Block
(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)
)
[/code]
> VVA
apnum: логичнее сделать для 1-го атрибута (независимо от количества атрибутов в блоке) или предупредить пользователя, что в выбранном блоке более 1-го атрибута.
А вообще, интересная и полезная программа.
> Сергей
Если уверен, что блок есть в пути и он с атрибутами, то это cond
(cond
((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
((and tembl (= 1 (cdr(assoc 66(entget(car temBl))))))
(setq apnum:Block(cdr(assoc 2(entget(car temBl)))))
); end condition #2
(t
(princ "\nBlock not contains attribute! ")
(setq apnum:Block nil)
); end condition #3
); end cond
удали или закоментируй
> Сергей
Модернизированный apnum. Теперь binc
(defun c:binc (/ oldStart oldPref oldSuf oldEcho
oldSize oldBlock temBl *error* att attr apnum:tag pt)
;==== Local functions ============
(defun *error* (msg)(setvar "CMDECHO" oldEcho)(setvar "ATTDIA" att)(setvar "ATTREQ" attr)(princ)); end *error*
(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))
)
)
)
)
)
)
)
;==== Local functions END ============
;====================================================================
(setq apnum:Block "BlockName") ;_Впиши имя блока здесь
(setq apnum:tag "Nomer") ;_Впиши имя тага атрибута
;===================================================================
(if(not apnum:Size)(setq apnum:Size 1.0))
(if(not apnum:Num)(setq apnum:Num 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
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 ""))
(setq apnum:Num
(getint
(strcat "\nSpecify start number <"(itoa apnum:Num)">: ")))
(if(null apnum:Num)(setq apnum:Num oldStart))
(setq apnum:Size
(getreal
(strcat "\nSpecify block scale <"(rtos apnum:Size)">: ")))
(if(null apnum:Size)(setq apnum:Size oldSize))
(if apnum:Block(setq oldBlock apnum:Block))
;;; (setq temBl
;;; (entsel(strcat "\nSelect block <"
;;; (if apnum:Block apnum:Block "not difined") "> > "))); end setq
(cond
((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
((and tembl (= 1 (cdr(assoc 66(entget(car temBl))))))
(setq apnum:Block(cdr(assoc 2(entget(car temBl)))))
); end condition #2
(t
(princ "\nBlock not contains attribute! ")
(setq apnum:Block nil)
); end condition #3
); end cond
(if apnum:Block
(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 (1+ apnum:Num))
); end while
); end progn
); end if
(setvar "ATTDIA" att)(setvar "ATTREQ" attr)
(princ)
)
(princ "\nType BINC to run")
В этих строчках
;====================================================================
(setq apnum:Block "BlockName") ;_Впиши имя блока здесь
(setq apnum:tag "Nomer") ;_Впиши имя тага атрибута
;===================================================================
вместо BlockName впиши имя блока, вместо Nomer - свое имя тага атрибута
И по прежнему номер-целое число. В твоем случае BTH 1. и BTH 2. нужно задавать как префикс
> VVA
У меня блоки имею шесть атрибутов:
1.N (по умолчанию BTH 1.1) в котором необходимо менять последнюю цифру;
2.ПОЗ
3.ТИП
4.МАРКА
5.ПРОИЗВОДИТЕЛЬ
6.ПОТРЕБЛЕНИЕ
Как быть в этом случаи?
И еще вопрос.
Можно ли сделать, чтобы при вызове apnum он не запрашивал блок, а всегда вставлял определенный блок?
И последняя программка BlockNum у меня не запускается!!!
> VVA
У меня блоки имею шесть атрибутов:
1.N (по умолчанию BTH 1.1) в котором необходимо менять последнюю цифру;
2.ПОЗ
3.ТИП
4.МАРКА
5.ПРОИЗВОДИТЕЛЬ
6.ПОТРЕБЛЕНИЕ
Как быть в этом случаи?
И еще вопрос.
Можно ли сделать, чтобы при вызове apnum он не запрашивал блок, а всегда вставлял определенный блок?
И последнюю программка BlockNum у меня запускается!!!
> Сергей
Если блок с одним атрибутом
;;Originally Posted by ASMI
;;http://www.cadtutor.net/forum/showthread.php?t=11114&page=2
;;https://www.caduser.ru/forum/topic33485.html
(defun c:apnum (/ 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: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 "\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 ""))
(setq apnum:Num
(getint
(strcat "\nSpecify start number <"(itoa apnum:Num)">: ")))
(if(null apnum:Num)(setq apnum:Num oldStart))
(setq apnum:Size
(getreal
(strcat "\nSpecify block scale <"(rtos apnum:Size)">: ")))
(if(null apnum:Size)(setq apnum:Size oldSize))
(if apnum:Block(setq oldBlock apnum:Block))
(setq temBl
(entsel(strcat "\nSelect block <"
(if apnum:Block apnum:Block "not difined") "> > "))); 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 "\nBlock not contains attribute! ")
(setq apnum:Block nil)
); end condition #3
); end cond
(if apnum:Block
(progn
(princ "\n>>> Pick insertion point or press Esc to quit <<<\n ")
(while T
(command "_-insert" apnum:Block "_s" apnum:Size pause "0"
(strcat apnum:Pref(itoa apnum:Num)apnum:Suf)); end command
(setq apnum:Num (1+ apnum:Num))
); end while
); end progn
); end if
(setvar "ATTDIA" att)
(princ)
); end of c:apnum
Номер-целое число. В твоем случае BTH 1. и BTH 2. нужно задавать как префикс
> iv
То, чем пользуюсь я
Команды NUM, RENUM - понятно
TTC - копирование содержимого из одного текста в другой (множественная и попарная)
Для Renum и TTC допустимые источники и приемники текста DIMENSION, TEXT, MTEXT, ATTRIB, ATTDEF, ACAD_TABLE
Apnum - тоже, что и NUM, но вставляет блок с одним атрибутом, увеличивая его значение
;;;https://www.caduser.ru/forum/topic29902.html
(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:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"num:Pref"> :")))
(if(= "" num:Pref)(setq num:Pref oldPref))
(if(= " " num:Pref)(setq num:Pref ""))
(setq num:Suf
(getstring T
(strcat "\nType suffix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"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
;To keep contents of the text
;;;Routine for Renumbering
;;;Realization {Smirnoff}
;;;https://www.caduser.ru/forum/topic29902.html
;;;https://www.caduser.ru/forum/topic21894.html
;;;Edition 23.10.2006 Vladimir Azarko (VVA)
;;;https://www.caduser.ru/forum/topic30467.html
(defun c:renum (/ oldPref oldSuf oldStart curText curStr vlaObj keepText)
(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" "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))
(setq oldPref rnm:Pref oldSuf rnm:Suf oldStart rnm:Start); end setq
(setq rnm:Pref (getstring T
(strcat "\nType prefix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"num: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) <"num: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))
(initget "Yes No ?? ??? _Yes No Yes No")
(setq keepText (not (= "No" (getkword "\nkeep contents of the text [Yes/No] <Yes>:"))))
(setq rnm:Start (1- rnm:Start))
(while (TTC_Paste (setq curStr(strcat rnm:Pref(itoa (setq rnm:Start(1+ rnm:Start)))rnm:Suf)) keepText))
(vla-EndUndoMark aDoc)(princ)); end of c:renum
(defun c:ttc (/ actDoc vlaObj sObj sText curObj oldForm
oType oldMode conFlag errFlag *error*)
(vl-load-com)
(setq actDoc(vla-get-ActiveDocument
(vlax-get-acad-object)))
(vla-StartUndoMark actDoc)
(defun TTC_Paste(pasteStr / nslLst vlaObj hitPt
hitRes Row Column)
(setq errFlag nil)
(if
(setq nslLst(nentsel "\nPaste text >"))
(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)))))))
(if
(vl-catch-all-error-p
(vl-catch-all-apply
'vla-put-TextOverride(list vlaObj pasteStr)))
(progn
(princ "\n Can't paste. Object may be on locked layer. ")
(setq errFlag T)
); end progn
); end if
); end condition #1
(
(and
(= 4(length nslLst))
(= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))
); end and
(setq vlaObj
(vlax-ename->vla-object
(cdr(assoc -1(entget(car(last nslLst))))))
hitPt(vlax-3D-Point(trans(cadr nslLst)1 0))
hitRes(vla-HitTest vlaObj hitPt
(vlax-3D-Point '(0.0 0.0 1.0)) 'Row 'Column)
); end setq
(if(= :vlax-true hitRes)
(progn
(if
(vl-catch-all-error-p
(vl-catch-all-apply
'vla-SetText(list vlaObj Row Column pasteStr)))
(progn
(princ "\n Can't paste. Object may be on locked layer. ")
(setq errFlag T)
); end progn
); end if
); end progn
); end if
); 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. Select Attribute ")
(setq errFlag T)
); end condition #3
(
(and
(= 2(length nslLst))
(member(cdr(assoc 0(entget(car nslLst))))
'("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))
); end and
(setq vlaObj
(vlax-ename->vla-object(car nslLst)))
(if
(vl-catch-all-error-p
(vl-catch-all-apply
'vla-put-TextString(list vlaObj pasteStr)))
(progn
(princ "\nError. Can't pase text. ")
(setq errFlag T)
); end progn
); end if
); end condition #4
(T
(princ "\nCan't paste. Invalid object. ")
(setq errFlag T)
); end condition #5
); end cond
T
); end progn
nil
); end if
); end of TTC_Paste
(defun TTC_MText_Clear(Mtext / Text Str)
(setq Text "")
(while(/= Mtext "")
(cond
((wcmatch
(strcase
(setq Str
(substr Mtext 1 2)))
"\\[\\{}`~]")
(setq Mtext(substr Mtext 3)
Text(strcat Text Str)
); end setq
); end condition #1
((wcmatch(substr Mtext 1 1) "[{}]")
(setq Mtext
(substr Mtext 2))
); end condition #2
(
(and
(wcmatch
(strcase
(substr Mtext 1 2)) "\\P")
(/=(substr Mtext 3 1) " ")
); end and
(setq Mtext (substr Mtext 3)
Text (strcat Text " ")
); end setq
); end condition #3
((wcmatch
(strcase
(substr Mtext 1 2)) "\\[LOP]")
(setq Mtext(substr Mtext 3))
); end condition #4
((wcmatch
(strcase
(substr Mtext 1 2)) "\\[ACFHQTW]")
(setq Mtext
(substr Mtext
(+ 2
(vl-string-search ";" Mtext))))
); end condition #5
((wcmatch
(strcase (substr Mtext 1 2)) "\\S")
(setq Str(substr Mtext 3 (- (vl-string-search ";" Mtext) 2))
Text(strcat Text (vl-string-translate "#^\\" " " Str))
Mtext(substr Mtext (+ 4 (strlen Str)))
); end setq
(print Str)
); end condition #6
(T
(setq Text(strcat Text(substr Mtext 1 1))
Mtext (substr Mtext 2)
)
); end condition #7
); end cond
); end while
Text
); end of TTC_MText_Clear
(defun TTC_Copy (/ sObj sText tType actDoc)
(if
(and
(setq sObj(car(nentsel "\nCopy text... ")))
(member(setq tType(cdr(assoc 0(entget sObj))))
'("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))
); end and
(progn
(setq actDoc(vla-get-ActiveDocument
(vlax-get-Acad-object))
sText(vla-get-TextString
(vlax-ename->vla-object sObj))
); end setq
(if(= tType "MTEXT")
(setq sText(TTC_MText_Clear sText))
); end if
); end progn
); end if
sText
); end of TTC_Copy
(defun CCT_Str_Echo(paseStr / comStr)
(if(< 20(strlen paseStr))
(setq comStr
(strcat
(substr paseStr 1 17)"..."))
(setq comStr paseStr)
); end if
(princ
(strcat "\nText = \"" comStr "\""))
(princ)
); end of CCT_Str_Echo
(defun *error*(msg)
(vla-EndUndoMark
(vla-get-ActiveDocument
(vlax-get-acad-object)))
(princ "\nQuit TTC")
(princ)
); end of *error*
(if(not ttc:Mode)(setq ttc:Mode "Multiple"))
(initget "Multiple Pair-wise")
(setq oldMode ttc:Mode
ttc:Mode
(getkword
(strcat "\nSpecify mode [Multiple/Pair-wise] <" ttc:Mode ">: "))
conFlag T
paseStr ""
); end setq
(if(null ttc:Mode)(setq ttc:Mode oldMode))
(if(= ttc:Mode "Multiple")
(progn
(if(and(setq paseStr(TTC_Copy))conFlag)
(progn
(CCT_Str_Echo paseStr)
(while(setq conFlag(TTC_Paste paseStr))T
); end while
); end progn
); end if
); end progn
(progn
(while
(and conFlag paseStr)
(setq paseStr(TTC_Copy))
(if(and paseStr conFlag)
(progn
(CCT_Str_Echo paseStr)
(setq errFlag T)
(while errFlag
(setq conFlag(TTC_Paste paseStr))
);end while
); end progn
); end if
); end while
); end progn
); end if
(vla-EndUndoMark actDoc)
(princ "\nQuit TTC")
(princ)
); end c:ttc
;;Originally Posted by ASMI
;;http://www.cadtutor.net/forum/showthread.php?t=11114&page=2
(defun c:apnum (/ 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: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 "\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 ""))
(setq apnum:Num
(getint
(strcat "\nSpecify start number <"(itoa apnum:Num)">: ")))
(if(null apnum:Num)(setq apnum:Num oldStart))
(setq apnum:Size
(getreal
(strcat "\nSpecify block scale <"(rtos apnum:Size)">: ")))
(if(null apnum:Size)(setq apnum:Size oldSize))
(if apnum:Block(setq oldBlock apnum:Block))
(setq temBl
(entsel(strcat "\nSelect block <"
(if apnum:Block apnum:Block "not difined") "> > "))); 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 "\nBlock not contains attribute! ")
(setq apnum:Block nil)
); end condition #3
); end cond
(if apnum:Block
(progn
(princ "\n>>> Pick insertion point or press Esc to quit <<<\n ")
(while T
(command "_-insert" apnum:Block "_s" apnum:Size pause "0"
(strcat apnum:Pref(itoa apnum:Num)apnum:Suf)); end command
(setq apnum:Num (1+ apnum:Num))
); end while
); end progn
); end if
(setvar "ATTDIA" att)
(princ)
); end of c:apnum
(princ "\nType in command line:")
(princ "\n\t Num - Insert text with increment value")
(princ "\n\t Renum - Renumbering text in DIMENSION, TEXT, MTEXT, ATTRIB, ATTDEF, ACAD_TABLE")
(princ "\n\t TTC - Text to Text copy. Copy text from DIMENSION, TEXT, MTEXT, ATTRIB, ATTDEF, ACAD_TABLE to one")
(princ "\n\t Apnum - for numbering by blocks with single attribute")
Сообщений найдено 11