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

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

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

Ответ
Поиск в этой теме
Непрочитано 23.01.2010, 11:39
Опять про 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.
Просмотров: 28557
 
Непрочитано 22.11.2010, 16:57
#21
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,990
<phrase 1= Отправить сообщение для VVA с помощью Skype™


Цитата:
Сообщение от 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,840


не проверял, запускать командой 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,990
<phrase 1= Отправить сообщение для VVA с помощью Skype™


можно ли автоматизировать нумерацию блоков
__________________
Как использовать код на Лиспе читаем здесь
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,840


переправил в п.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,990
<phrase 1= Отправить сообщение для VVA с помощью Skype™


Добавлена сортировка по точке вставки блоков слева-направо, снизу-вверх
Код:
[Выделить все]
(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
Россия, Энгельс
Сообщений: 40


уважаемый 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
Сообщений: 650


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

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,990
<phrase 1= Отправить сообщение для VVA с помощью Skype™


Цитата:
Сообщение от 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