[Макс Тал.]

Кто поможет воплотить идею в реальность?
Нужен лисп.
Охото чтобы команда спрашивала
1. Выберите числа, которые необходимо сложить.
2.После выделения запрос на место размещения результата.
3. Вставка результата.
Возникла необходимость в суммировании большого количества чисел и забивать каждое число в формулу очень нудно и долго.
У меня есть лисп который прибавляет к выделенным числам величину, которую указываешь в командной строке при запросе.

[favorite]

1.А для чего это надо?
2. Что значит забивать числа в формулу, в CAD калькулятор есть
3. Числа они, что mtext ОМ в Cad написаны и их надо сложить. :?:

[favorite]

Код:

[Выделить все]

; автор Зурабян Давид Артемович
; Программа сложения чисел
(defun C:SUmm (/ sUMM Au )
  (vl-load-com)
  (setq app (vla-get-modelspace(vla-get-activedocument(vlax-get-acad-object))))
  (prompt "Выберети объекты")
  (setq AU (ssget '((0 . "mtext" ))))
  (setq N (sslength AU))
  (setq i 0)
  (setq Summ 0)
  (while (< i n)
    (setq name1 (ssname Au i))
    (setq ENT_name1 (entget name1))
    (setq NAME (Vlax-ename->vla-object name1))
    (vlax-dump-object name)
(setq Summ (+ Summ (atof (vla-get-textstring name))))
(setq i (1+ i))
 )
    (setq Pt1 (getpoint "вВЕДИТЕ ТОЧКУ ВСТАВКИ"))
    (vL-CMDF "._text" PT1  250 0  (STRCAT " = "  (RTOS SUMM)))
)

Вот глянь. То

[Кулик Алексей aka kpblc]

Код:

[Выделить все]

(defun c:summ (/		   res		       *kpblc-activedoc*
	       selset		   _kpblc-get-active-space-obj
	       ins_pt		   txt_height
	       )

  (defun _kpblc-get-active-space-obj ()
    (if	(and (zerop (vla-get-activespace *kpblc-activedoc*))
	     (= :vlax-false (vla-get-mspace *kpblc-activedoc*))
	     ) ;_ end of and
      (vla-get-paperspace *kpblc-activedoc*)
      (vla-get-modelspace *kpblc-activedoc*)
      ) ;_ end of if
    ) ;_ end of defun

  (vl-load-com)
  (setq	*kpblc-activedoc*
	 (vla-get-activedocument (vlax-get-acad-object))
	res 0.
	) ;_ end of setq
  (vla-startundomark *kpblc-activedoc*)
  (if (setq selset (ssget '((0 . "TEXT,MTEXT"))))
    (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
      (setq
	res (+ res (atof (vla-get-textstring (vlax-ename->vla-object ent))))
	) ;_ end of setq
      ) ;_ end of foreach
    ) ;_ end of if
  (if (and (not (equal res 0. 1e-3))
	   (setq ins_pt (getpoint "\nУкажите точку вставки результата : "))
	   ) ;_ end of and
    (progn
      (if (= (setq txt_height
		    (vla-get-height
		      (vla-get-activetextstyle *kpblc-activedoc*)
		      ) ;_ end of vla-get-Height
		   ) ;_ end of setq
	     0.
	     ) ;_ end of =
	(if
	  (not (setq txt_height (getreal "\nВведите высоту текста <2.5> : ")))
	   (setq txt_height 2.5)
	   ) ;_ end of if
	) ;_ end of if
      (vla-addmtext
	(_kpblc-get-active-space-obj)
	(vlax-3d-point ins_pt)
	1.
	(rtos res 2)
	) ;_ end of vla-AddMText
      ) ;_ end of progn
    ) ;_ end of if
  (vla-endundomark *kpblc-activedoc*)
  (princ)
  ) ;_ end of defun

Без особых проверок

[Om81]

Чтобы не создавать новую тему..
Нужен такой (видимо) лисп: есть задача посчитать количество текстовых объектов с одинаковым содержимым (contents) - нужно для спецификации по технологии..
Т.е. требуется результат в виде списка типа:
1 - 1 шт
2 - 12 шт
3 - 48 шт
и т.д.. у меня позиций около тысячи, и каждой по многу штук. Я делаю через Quick Select - text- contents = хх, он выбирает и пишет в панели пропертис сколько штук со значением "хх" выбрано. Только думаю, вручную до пятницы не управлюсь))) Все числа в виде text, в одном слое..
Если кто знает о существовании где-либо такого лиспа - подскажите, я их до этого не искал.. :roll:

[Кулик Алексей aka kpblc]

Код Эдуарда, у моих работает:

Код:

[Выделить все]

(defun ed_wrdcount (/ descript fnam txtstr txtspace lst lstp tvst)
  (vl-load-com)
  (if
    (setq lst (ssget (list '(0 . "TEXT") (cons 410 (getvar "ctab")))))
     (progn
       (setq txtspace (vla-objectidtoobject
			(vla-get-activedocument (vlax-get-acad-object))
			(vla-get-ownerid
			  (vlax-ename->vla-object (ssname lst 0))
			  ) ;_ end of vla-get-ownerid
			) ;_ end of vla-ObjectIDToObject
	     ) ;_ end of setq
       (setq lst (mapcar '(lambda (x) (cdr (assoc 1 (entget x))))
			 (vl-remove-if
			   'listp
			   (mapcar 'cadr
				   (ssnamex lst)
				   ) ;_ end of mapcar
			   ) ;_ end of vl-remove-if
			 ) ;_ end of mapcar
	     ) ;_ end of setq

       (foreach	i lst
	 (if (not (assoc i lstp))
	   (setq lstp
		  (cons
		    (list i
			  (length
			    (vl-remove-if-not
			      '(lambda (x) (= i x))
			      lst
			      ) ;_ end of vl-remove-if-not
			    ) ;_ end of length
			  ) ;_ end of list
		    lstp
		    ) ;_ end of cons
		 ) ;_ end of setq
	   ) ;_ end of if
	 ) ;_ end of foreach
       (setq txtstr
	      (apply
		'strcat
		(mapcar
		  '(lambda (x) (strcat (car x) " - " (itoa (cadr x)) "øò " "\\P"))
		  lstp
		  ) ;_ end of mapcar
		) ;_ end of apply
	     ) ;_ end of setq
       (if
	 (setq tvst (getpoint "\nSpecify start point of text:"))
	  (vla-addmtext txtspace (vlax-3d-point tvst) 10000 txtstr)
	  ) ;_ end of if
       ) ;_ end of progn
     ) ;_ end of if
  (princ)
  ) ;_ end of defun

[Om81]

Что-то не понимаю.. загрузил ее через appload, а что дальше делать?))

[_Andre_]

а теперь в командной строке пиши

Код:

[Выделить все]

(ed_wrdcount)

и жми ентер.

Или на кнопку повесить макрос можно

Код:

[Выделить все]

^c^c(ed_wrdcount)

при условии что файлик с лиспом прописан в автозагрузке

[Om81]

Спасибо, забыл про скобки)
Из минусов - почему-то какие-то два нолика после каждого числа стоят)) И самое главное - порядковые номера не отсортированы по возрастанию ((

[_Andre_]

Вот так тогда

Код:

[Выделить все]

(defun ed_wrdcount (/ descript fnam txtstr txtspace lst lstp tvst)
  (vl-load-com)
  (if
    (setq lst (ssget (list '(0 . "TEXT") (cons 410 (getvar "ctab")))))
     (progn
       (setq txtspace (vla-objectidtoobject
			(vla-get-activedocument (vlax-get-acad-object))
			(vla-get-ownerid
			  (vlax-ename->vla-object (ssname lst 0))
			) ;_ end of vla-get-ownerid 
		      ) ;_ end of vla-ObjectIDToObject 
       ) ;_ end of setq 
       (setq lst (mapcar '(lambda (x) (cdr (assoc 1 (entget x))))
			 (vl-remove-if
			   'listp
			   (mapcar 'cadr
				   (ssnamex lst)
			   ) ;_ end of mapcar 
			 ) ;_ end of vl-remove-if 
		 ) ;_ end of mapcar 
       ) ;_ end of setq 

       (foreach	i lst
	 (if (not (assoc i lstp))
	   (setq lstp
		  (cons
		    (list i
			  (length
			    (vl-remove-if-not
			      '(lambda (x) (= i x))
			      lst
			    ) ;_ end of vl-remove-if-not 
			  ) ;_ end of length 
		    ) ;_ end of list 
		    lstp
		  ) ;_ end of cons 
	   ) ;_ end of setq 
	 ) ;_ end of if 
       ) ;_ end of foreach 
       (setq txtstr
	      (apply
		'strcat
		(mapcar
		  '(lambda (x)
		     (strcat (car x) " - " (itoa (cadr x))  "\\P")
		   )
		  (vl-sort lstp '(lambda (y1 y2) (> (car y1) (car y2))))
		) ;_ end of mapcar 
	      ) ;_ end of apply 
       ) ;_ end of setq 
       (if
	 (setq tvst (getpoint "\nSpecify start point of text:"))
	  (vla-addmtext txtspace (vlax-3d-point tvst) 10000 txtstr)
       ) ;_ end of if 
     ) ;_ end of progn 
  ) ;_ end of if 
  (princ)
)

[Om81]

Andre, спасибо большое!

[Тим]

А можно немножко усовершенствовать ЛИСП суммирования?
Например, чтобы сумма чисел вставлялась с помощью редактирования текста, то есть имея например число "0" уже нарисованное, кликнуть на нем, и оно становится той самой суммой, результат выводился в виде например 22.56,то есть с округлением до сотых.
И все тоже самое для умножения.
Если это выполнимо, помогите плиз!

[Лентяй]

Ох, уж эти ssget-чики, поубивав бы [sm3218]

Код:

[Выделить все]

;Выборка по всем пространствам, вставка текста - в пространство листа, как водится у приличных людей.
;Присваивание свойств текста - по отдельному требованию Заказчика.
(defun ed_wrdcount (/ adoc ass ms ps util txt lst)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (mapcar '(lambda (x y) (set x (vlax-get-property adoc y))) '(ass util ms ps)
	    '(ActiveSelectionset Utility ModelSpace PaperSpace))
  (if (> (vla-get-count ass) 0) (vla-clear ass))
  (mapcar '(lambda (x) (vlax-for it x
         (if (and (wcmatch (vla-get-Objectname it) "*Text")
                  (not (assoc (setq txt (vla-get-TextString it)) lst)));and
           (progn (vla-Select ass acSelectionSetAll nil nil
               (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 1)) '(0 1))
               (vlax-safearray-fill (vlax-make-safearray vlax-vbvariant '(0 . 1)) (list "*Text" txt)))
             (setq lst (cons (list txt (itoa (vla-get-count ass))) lst))
             (vla-clear ass))))) (list ms ps));mapcar
  (mapcar '(lambda (x) (vlax-put-property adoc x 0)) '(ActiveSpace Mspace))
  (vla-addMtext ps (vla-getPoint util nil "\nТочка вставки текста") 0
    (apply 'strcat (mapcar '(lambda (x) (strcat (car x) " - " (cadr x)  "шт.\\P"))
                     (vl-sort lst '(lambda (y1 y2) (< (car y1) (car y2)))))));addMtext
  (princ)
);end

[Тим]

Неужели такая сложная задача, кажется вы и покруче решали....

[Лентяй]

Сообщение от Тим Неужели такая сложная задача, кажется вы и покруче решали....

Потому и не решаем, что не круто и, стало быть, неинтересно. :twisted: Впрочем, держи прогу.

Код:

[Выделить все]

(defun C:MathTxt ( / adoc util txt opt act val) 
  (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object))
        util (vla-get-utility adoc))
  (if (not (vl-catch-all-error-p (vl-catch-all-apply
        '(lambda () (vla-getentity util 'txt nil "Выберите число")))))
      (if (= (vla-get-objectname txt) "AcDbText")
        (if (not (wcmatch (setq str (vla-get-TextString txt)) "*@*,*-*,*/*")) (progn
          (vla-InitializeUserInput util 128 "Cложить Вычесть Умножить Разделить")
          (if (null opt0) (setq opt0 "Cложить"))
          (setq opt (vla-getKeyword util (strcat "Выберите действие [Cложить/Вычесть/Умножить/Разделить] <" opt0 ">: ")))
          (if (= opt "") (setq opt opt0) (setq opt0 opt))
          (mapcar '(lambda (x y) (if (= opt x) (setq act y))) '("Cложить" "Вычесть" "Умножить" "Разделить") (list + - * /))
          (if (null val0) (setq val0 0))
          (if (not (vl-catch-all-error-p (vl-catch-all-apply
        	'(lambda () (setq val (vla-getReal util (strcat "\nВведите чило <" (rtos val0 2 2) ">: ")))))))
            (setq val0 val) (setq val val0));if
          (if (and (= opt "Разделить") (= val 0)) (progn (alert "Не дели на 0, дубина!") (princ)));if
          (vla-put-TextString txt (rtos (act (atof str) val) 2 2)));progn
        (alert "\nЭто не число! Разуй глаза и выбери снова!"));if
        (alert "\Это не текст! Выбирай внимаельнее"));if
    (alert "Ни фига не выбрано!"));if
);end

Учти. что прога написана для английской версии. т.е для дестичного знака "точка". а не "запятая".

[Тим]

Большое спасибо за проявленное терпение, только вот
" ; ошибка: неверный тип аргумента: numberp: nil", ругается.....

[pyatifan]

А как насчёт калькулятора таблиц от Эдуарда? Так и не обкатали:

Код:

[Выделить все]

(defun C:table-f () 
  (if 
    (and 
      (setq tbl-obj (car 
            (entsel "\n Выберите таблицу:") 
          ) 
      ) 
      (equal 
   (vla-get-objectname 
     (vlax-ename->vla-object tbl-obj) 
   ) 
   "AcDbTable" 
      ) 
    )               ;and 
     (progn 
       (initget "*  +") 
       (setq aop (getkword "\n Введите знак операции[*  +][+]:")) 
       (if (not aop) 
    (setq aop "+") 
       )            ;if 
       (setq aop (read aop)) 
       (initget "Строка Колонка") 
       (setq 
    cr (getkword 
         "\n Выполнять операцию над [Строка \ Колонка][Строка]:" 
       ) 
       ) 
       (if 
    (not cr) 
     (setq cr "Строка") 
       )            ;if 
       (setq data (mapcar 'cdr 
           (vl-remove-if-not 
             '(lambda (x) 
                (= (car x) 1) 
              ) 
             (entget tbl-obj) 
           ) 
        ) 
       ) 
       (setq tbl-obj 
         (vlax-ename->vla-object tbl-obj) 
       ) 

       (setq size (list 
          (vla-get-columns tbl-obj) 
          (vla-get-rows tbl-obj) 
        ) 
       )            ;setq 

       (setq data (cdr (data-list data (car size)))) 
       (if (equal cr "Колонка") 
    (setq data (apply 'mapcar (cons 'list data))) 


       )            ;if 

       (setq 
    data (mapcar '(lambda (y) 

          (setq y (mapcar '(lambda (w) 
                   (vl-string-translate "," "." w) 
                 ) 
                (reverse (cdr (reverse y))) 
             ) 
          ) 

          (setq y (vl-remove-if-not 
               '(lambda (z) 
                  (or 
               (equal (type (read z)) 'INT) 
               (equal (type (read z)) 'REAL) 
                  ) 
                ) 
               y 
             ) 
          ) 
          (mapcar 'distof y) 
             ) 
            data 
         ) 
       )            ;setq 
       (setq data (mapcar 'rtos 
           (mapcar '(lambda (q) 
                 (apply aop q) 
               ) 
              data 
           ) 
        ) 
       ) 

       (if 
    (equal cr "Строка") 
     (progn 
       (setq j 1) 
       (foreach k data 
         (vla-settext tbl-obj j (1- (car size)) k) 
         (setq j (1+ j)) 
       ) 
     ) 
     (progn 
       (setq j 0) 
       (foreach k data 
         (vla-settext tbl-obj (1- (cadr size)) j k) 
         (setq j (1+ j)) 
       ) 
     ) 

       ) 
     ) 
  ) 
  (princ) 
) 

(defun data-list (lst memb / rez rez2) 

  (setq i 0) 
  (foreach x lst 
    (setq i (1+ i)) 
    (if 
      (and 
   (/= i 1) 
   (zerop 
     (rem 
       (1- i) 
       memb 
     ) 
   ) 
      ) 
       (progn 
    (setq rez 
      (cons 
        (reverse rez2) 
        rez 
      ) 
    ) 
    (setq rez2 '()) 
       ) 
    ) 

    (setq rez2 (cons x rez2) 
    ) 
  ) 
  (setq   rez (reverse 
         (cons 
      (reverse rez2) 
      rez 
         ) 
       ) 
  ) 
)

http://dwg.ru/forum/viewtopic.php?p=...ghlight=#88092

Вроде не так просто, и интересно...

[Лентяй]

Сообщение от Тим Большое спасибо за проявленное терпение, только вот " ; ошибка: неверный тип аргумента: numberp: nil", ругается.....

В каком именно месте эта скотина смеет ругацца :?: :twisted: И потом, какой АвтоКАД используется - русский или английский? Потому как я предупреждал:

Учти, что прога написана для английской версии. т.е для дестичного знака "точка". а не "запятая".

[Тим]

Акад 2006 RUS, но ругается сразу при загрузке приложения

[Лентяй]

У меня AutoCAD-2005 ENG, и все работает. ОДНАКО! Я применил один грязный трюк :twisted: , в котором, может быть, и состоит причина неприятия проги 2006-м. Ниже - более "законный" вариант.

Код:

[Выделить все]

(defun C:MathTxt ( / adoc util txt opt val) 
  (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object)) 
        util (vla-get-utility adoc)) 
  (if (not (vl-catch-all-error-p (vl-catch-all-apply 
        '(lambda () (vla-getentity util 'txt nil "Выберите число"))))) 
      (if (= (vla-get-objectname txt) "AcDbText") 
        (if (not (wcmatch (setq str (vla-get-TextString txt)) "*@*,*-*,*/*")) (progn 
          (vla-InitializeUserInput util 128 "Cложить Вычесть Умножить Разделить") 
          (if (null opt0) (setq opt0 "Cложить")) 
          (setq opt (vla-getKeyword util (strcat "Выберите действие [Cложить/Вычесть/Умножить/Разделить] <" opt0 ">: "))) 
          (if (= opt "") (setq opt opt0) (setq opt0 opt)) 
          (if (null val0) (setq val0 0)) 
          (if (not (vl-catch-all-error-p (vl-catch-all-apply 
           '(lambda () (setq val (vla-getReal util (strcat "\nВведите чило <" (rtos val0 2 2) ">: "))))))) 
            (setq val0 val) (setq val val0));if 
          (if (and (= opt "Разделить") (= val 0)) (progn (alert "Не дели на 0, дубина!") (princ)));if 
          (vla-put-TextString txt (rtos ((cond ((= opt "Cложить") +) ((= opt "Вычесть") -)
                                              ((= opt "Умножить") *) ((= opt "Разделить") /)) (atof str) val) 2 2)));progn
        (alert "\nЭто не число! Разуй глаза и выбери снова!"));if 
        (alert "\Это не текст! Выбирай внимаельнее"));if 
    (alert "Ни фига не выбрано!"));if 
);end

Попробуй его, и немедленно должь о результатах. [sm2001]

[Тим]

Все нормально, заработала, но задача немножко в другом:
Это все можно и в Excele делать, таблицы, спецефикации и т.д, но возникает иногда необходимость сложить (умножить) группу цифр, расположенных на чертеже между собой.
Единственная цель энтого действа, не перебивать все значения, полученные в результате так сказать черчения, потом на калькуляторе.
Примерный алгоритм выполнения:

1 Выберите числа над которыми необходимо произвести действие;
(рамкой выделяется группа чисел, над которыми хочется поглумится)
2 Укажите значение текста, подлежащее редактированию;
(командой DDEDIT редактируется имеющийся однострочный текст)

Примерно такая прога имеется:

(defun c:CalcTXTVal(/ nab i)
(print "Выберите текстовые объекты среди которых будет произведененна калькуляция")
(setq nab (ssget '((0 . "TEXT")))
i 0)
(while (/= (sslength nab) 0)
(setq i (+ i
(atof (vl-string-subst
"."
","
(cdr (assoc 1 (entget (ssname nab 0))))))))
(ssdel (ssname nab 0) nab))
(print (strcat "Сумма = " (rtos i 2 2)))
(princ))

Только здесь сумма выводится в командную строку, а хотелось бы сразу на экран.
И для удобства 2 программы, отдельно, для умножения и сложения.

[Лентяй]

Не въехал. То, что выбранные чила можно складывать между собой, это понятно. Но перемножать...[sm2100] Может. все-таки каждое число из выбранной группы умножить на некий постоянный множитель? Проясните, плз. Пока что - держите сложение всего вместе.

Код:

[Выделить все]

(defun C:SumTxt ( / adoc ass txt str val) 
  (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object))        
        ass (vla-get-ActiveSelectionSet adoc) val 0)
  (if (> (vla-get-count ass) 0) (vla-clear ass))
  (vla-selectOnScreen ass (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 0)) '(0)) 
    (vlax-safearray-fill (vlax-make-safearray vlax-vbvariant '(0 . 0)) (list "Text")))
  (if (> (vla-get-count ass) 0)(progn      
    (vlax-for txt ass
      (if (not (wcmatch (setq str (vla-get-TextString txt)) "*@*,*-*,*/*"))
        (progn (if (wcmatch str ",") (setq str (vl-string-subst "," "." str)))
          (setq val (+ val (atof str))))));vlax-for
    (setq txt (vla-addText (if (= (getvar "CVPORT") 2) (vla-get-ModelSpace adoc) (vla-get-PaperSpace adoc));if
                (rtos val 2 2) (vla-getPoint (vla-get-utility adoc) nil "Укажите точку вставки текста") 1.0))
    (mapcar '(lambda (x y) (vlax-put-property txt x y)) (setq txpr '(Layer Color Height StyleName ScaleFactor))
      (mapcar '(lambda (z) (vlax-get-property (vla-item ass 0) z)) txpr)));progn
    (alert "Ни фига не выбрано!"));if
);end

[Тим]

Ну да, с умножением я грубанул, много числов конечно не нужно перемножать, нужно всего два
выбрать одно
выбрать второе
получить результат

[Лентяй]

А вставлять- то куды? (Гусары, молчать!) Я имею в вижу - вместо первого, второго, или в указанное курсором место? Держите универсалбный вариант.

Код:

[Выделить все]

(defun C:MultTxt ( / adoc util txt txt1 txt2 str1 str2 opt val) 
  (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object)) 
        util (vla-get-utility adoc) val 0) 
  (if (apply 'and (mapcar '(lambda (x y) (not (vl-catch-all-error-p (vl-catch-all-apply 
        		'(lambda () (vla-getentity util x nil (strcat "Выберите " y " число")))))))
                    '(txt1 txt2) '("первое" "второе")));apply
     (if (apply 'and (mapcar '(lambda (x) (= (vla-get-objectname x) "AcDbText")) (list txt1 txt2)))
       (progn (setq str (mapcar '(lambda (x) (vla-get-TextString x)) (list txt1 txt2)))
         (if (apply 'and (mapcar '(lambda (x) (not (wcmatch x "*@*,*-*,*/*"))) str)) (progn
             (setq val (apply '* (mapcar '(lambda (x)
               (atof (if (wcmatch x ",") (setq x (vl-string-subst "," "." x)) x))) str)));setq
          (vla-InitializeUserInput util 128 "Первое Второе Новое") 
          (if (null opt0) (setq opt0 "Новое")) 
          (setq opt (vla-getKeyword util (strcat "Заместить число [Первое/Второе/Новое] <" opt0 ">: "))) 
          (if (= opt "") (setq opt opt0) (setq opt0 opt))
          (cond ((= opt "Первое") (vla-put-TextString txt1 (rtos val 2 2)))
                ((= opt "Второе") (vla-put-TextString txt2 (rtos val 2 2)))
                ((= opt "Новое")
                 (setq txt (vla-addText (if (= (getvar "CVPORT") 2) (vla-get-ModelSpace adoc) (vla-get-PaperSpace adoc));if
                             (rtos val 2 2) (vla-getPoint util nil "Укажите точку вставки текста") 1.0))
                 (mapcar '(lambda (x y) (vlax-put-property txt x y)) (setq txpr '(Layer Color Height StyleName ScaleFactor))
                   (mapcar '(lambda (z) (vlax-get-property txt1 z)) txpr)))));progn
         (alert "\nЭто не число! Разуй глаза и выбери снова!")));progn
       (alert "\Это не текст! Выбирай внимаельнее"));if
    (alert "Пара не выбрана!"));if
);end

[Тим]

Огромное спасибо товарищу Лентяю за проявленное терпение и оказанную помощь, как расплачиваться буду прямо не знаю, может подскажешь?
И кстати вопрос: "Где находится граница между помощью и коммерцией, какого уровня сложности задачи решаются уже за денги?"

Lisp для суммирование длин выделенных линий - однажды на просторах инета встретил описание такого лиспа, но нигде не мог найти исходника. Может у кого-нибудь есть? :?: :shock:[[/b]

[DEM]

На Автокад.ру смотри в готовых программах или лиспе.
Щас нет времени искать.

[Лентяй]

Сообщение от Тим Огромное спасибо товарищу Лентяю за проявленное терпение и оказанную помощь,

Всегда пожалуйста! Не забывайте только денно и нощно сугубо и трегубо благодарить меня. любимого, за то, что я есть.

как расплачиваться буду прямо не знаю, может подскажешь?

Натурой :twisted:

И кстати вопрос: "Где находится граница между помощью и коммерцией, какого уровня сложности задачи решаются уже за денги?"

Помощь - это когда получаешь работу за бесплатно, ну, типа, как любовь - это когда получаешь за бесплатно секс. :twisted: :twisted:

[Олег К.]

Сам пишу подобную прогу, нашел эту тему и решил добавить свои размышления (надеюсь, тему еще кто-то просматривает).
ACAD2006, в качестве стандартного шрифта у нас используется Arial Narrow. При взятии числа из текста с помощью конструкции:
(setq numtext (atof (vl-string-translate "," "." (vla-get-textstring (vlax-ename->vla-object (car (entsel "\n Укажите текст:")))))))
возникает проблема с русскими символами, а точнее упорно выдает число 0.0 если раньше вместо цифр был какой-либо русский текст (типа: взяли MText с русскими буквами, скопировали его и заменили текст на число). Как ни странно такого не происходит если меняется латиница на число или создан новый MText с вводом числа в русской раскладке (запятая то, по идее, русским шрифтом пишется). Entget на русский текст выдает (1 . "{\\fArial Narrow|b0|i0|c204|p34;12.5}"), для сравнения латиница: (1 . "10,2"), или еще вариант: (1 . "qwerty {\\fArial Narrow|b0|i0|c204|p34;йцукен qwerty}").
Если кто знает, как получить содержимое текста без записей форматирования, УМОЛЯЮ, напишите.
Кстати, попробовал прогу от Лентяя (пост №24) – отказывается воспринимать второе число, говорит “это не текст”, попробовал выбрать числа в обратном порядке – та же фигня.
Извините что так длинно, не удивлюсь, если ответ на мою просьбу уместится в одной строке.

[VVA]

1.http://www.autocad.ru/cgi-bin/f1/board.cgi?t=20905TQ
2.StripMtext v3.07
3. Может так по

Код:

[Выделить все]

(setq txt "{\\fArial Narrow|b0|i0|c204|p34;12.5}") 
(setq num (VL-STRING-TRIM "{}" (if (cadr(setq num (str-str-lst  txt ";")))(cadr num)(car num))))

Ф-ция str-str-lst

[Олег К.]

Огромное спасибо, что подсказали где искать. Да-а, ответ действительно одной строкой . Понравилась программа от Kpblc’а, но объем великоват, так что применил функцию str-str-lst. У меня на компе работает замечательно, попробовал на другом – снова ошибки. В этот раз текст “793,44” записан в виде: (1 . "793{\\fArial Narrow|b0|i0|c204|p34;,}44"). И как теперь разделить мух с котлетами вообще не представляю, может есть у кого простое решение?

[Кулик Алексей aka kpblc]

Код:

[Выделить все]

_$ (kpblc-string-mtext-unformat "793{\\fArial Narrow|b0|i0|c204|p34;,}44")
"793,44"

На всякий случай код (потому как я там что-то менял достаточно давно).

Код:

[Выделить все]

;|=============================================================================
*    Функция сносит форматирование многострочного текста. Удаляются символы "{"
* и "}", поскольку именно символ "}" является окончанием применения определенного
* фонта. Удаляются наборы типа {fTimes New Roman|b0|i0|c204|p18; и т.п.
*    Параметры вызова:
*	string-to-normalize	- строка, которую надо нормализовать
*    Примеры вызова:
(_kpblc-clear-mtext (cdr (assoc 1 (entget(car(entsel))))))
	; для выбранного многострочного текста очищает форматирование.
=============================================================================|;
(defun _kpblc-clear-mtext	(string-to-normalize		     /
			 sub_string	   sub_pos	     left_string
			 right_string
			 )
  (if (or
	(setq sub_pos (vl-string-search "{f" string-to-normalize))
	(setq sub_pos (vl-string-search "{\\" string-to-normalize))
	(setq sub_pos (vl-string-search "\\f" string-to-normalize))
	(setq sub_pos (vl-string-search "{\\f" string-to-normalize))
	) ;_ end of or
    (progn
      (setq left_string			;все, что до "{"
	     (substr
	       string-to-normalize
	       1
	       sub_pos
	       ) ;_ end of substr
	    ) ;_ end of setq
      (vl-catch-all-error-p
	(setq right_string		;все, что между {f и ;
	       (substr
		 string-to-normalize
		 (+ (vl-string-position (ascii ";") string-to-normalize sub_pos) 2)
		 ) ;_ end of substr
	      ) ;_ end of setq
	) ;_ end of vl-catch-all-error-p
      (setq sub_string (strcat left_string right_string))
      (if (setq sub_pos (vl-string-search "}" sub_string))
	(setq sub_string
	       (strcat
		 (substr sub_string 1 sub_pos)
		 (substr sub_string (1+ sub_pos))
		 ) ;_ end of strcat
	      ) ;_ end of setq
	) ;_ end of if
      (_kpblc-clear-mtext sub_string)
      ) ;_ end of progn
    (vl-string-trim "}" string-to-normalize)
    ) ;_ end of if
  ) ;_ end of defun
;|=============================================================================
*    Функция очистки форматирования многострочного текста. Не гарантируется,
* что найдены все варианты форматирования. Также заменяет все переводы строк
* на "\n"
*    Параметры вызова:
*	ent	Текстовая строка, с которой надо снять форматирование
*    Исходный код взят с ruCAD, без переделок.
=============================================================================|;
(defun kpblc-string-mtext-unformat (ent			  /
				    _tmp		  _substr
				    _mtext-str-extractor-clr
				    _mtext-str-extractor-clr
				    )
  (defun _mtext-str-extractor-clr (str / _pos)
    (if	(setq _pos (_mtext-str-extractor-srch
		     str
		     '("{\\" "\\f" "\\F")
		     ) ;_ end of _mtext-str-extractor-srch
	      ) ;_ end of setq
      (strcat
	(if (> _pos 0)
	  (substr str 1 _pos)
	  ""
	  ) ;_ end of if
	(_mtext-str-extractor-clr
	  (substr
	    str
	    (+ 2 (vl-string-search ";" str (1+ _pos)))
	    ) ;_ end of substr
	  ) ;_ end of _mtext-str-extractor-clr
	) ;_ end of strcat
      str
      ) ;_ end of if
    ) ;_ end of defun
  (defun _mtext-str-extractor-srch (str lst / _tmp)
    (car (vl-sort
	   (vl-remove-if
	     'not
	     (mapcar (function (lambda (_x _y)
				 (vl-string-search _y _x)
				 ) ;_ end of lambda
			       ) ;_ end of function
		     (repeat (length lst)
		       (setq _tmp (cons str _tmp))
		       ) ;_ end of repeat
		     lst
		     ) ;_ end of mapcar
	     ) ;_ end of vl-remove-if
	   '<
	   ) ;_ end of vl-sort
	 ) ;_ end of car
    ) ;_ end of defun
  (setq
    _tmp (vl-string-subst
	   ""
	   "}"
	   (_mtext-str-extractor-clr
	     (_kpblc-string-replace
	       (_kpblc-string-replace
		 (_kpblc-string-replace
		   (_kpblc-string-replace
		     (_kpblc-string-replace
		       (_kpblc-string-replace
			 ent
					;) ;_ end of vla-get-textstring
			 "\\\\"
			 ""
			 ) ;_ end of _kpblc-string-replace
		       "\\{"
		       (chr 1)
		       ) ;_ end of _kpblc-string-replace
		     "\\}"
		     (chr 2)
		     ) ;_ end of _kpblc-string-replace
		   "\\P"
		   "\n"
		   ) ;_ end of _kpblc-string-replace
		 "\\L"
		 ""
		 ) ;_ end of _kpblc-string-replace
	       "\\l"
	       ""
	       ) ;_ end of _kpblc-string-replace
	     ) ;_ end of _mtext-str-extractor-clr
	   ) ;_ end of vl-string-subst
    ) ;_ end of setq
  (while
    (and (setq _substr (_kpblc-string-cut-between _tmp "\\" ";" nil))
	 (/= _substr "")
	 ) ;_ end of and
     (setq _tmp (vl-string-subst "" _substr _tmp))
     ) ;_ end of while
  (vl-string-subst "}" (chr 2) (vl-string-subst "{" (chr 1) _tmp))
  _tmp
  ) ;_ end of defun

;|=============================================================================
*    Функция замены вхождений подстроки в исходную строку на новые.
* Регистрозависимо
*    Параметры вызова:
*	string		исходная строка
*	ols_substr	старая подстрока
*	new_substr	новая подстрока
*    Примеры вызова:
(_kpblc-string-replace "Здесь были ВаВася и ВаВаВаня. Вася" "Ва" "Бу")
	; "Здесь были Буся и Буня. Буся"
=============================================================================|;
(defun _kpblc-string-replace (string old_substr new_substr / pos)
  (while (setq pos (vl-string-search old_substr string))
    (setq string
           (strcat
             (substr string 1 pos)
             new_substr
             (_kpblc-string-replace
               (substr string (+ (strlen old_substr) pos 1))
               old_substr
               new_substr
               ) ;_ end of _kpblc-string-replace
             ) ;_ end of strcat
          ) ;_ end of setq
    ) ;_ end of while
  string
  ) ;_ end of defun

Функции в значительной части слизаны с ruCAD'a

[VVA]

А если так

Код:

[Выделить все]

(defun mknum (str / pat str1 lst num)
  (setq pat (VL-STRING->LIST "{}"))
  (setq str1 (VL-LIST->STRING (mapcar '(lambda (x)(if(member x pat) 003 x))(VL-STRING->LIST str))))
  (setq lst (str-str-lst str1 (chr 003)))
  (VL-STRING-TRANSLATE "," "."
  (apply 'strcat (vl-remove-if 'null (mapcar '(lambda (x)(if (cadr(setq num (str-str-lst x ";")))(cadr num)(car num))) lst))))
) ;_  defun

str-str-lst та же
Пример

Код:

[Выделить все]

(setq txt "793{\\fArial Narrow|b0|i0|c204|p34;,}44")
(mknum txt) -> "793.44"

(setq txt "{\\fArial Narrow|b0|i0|c204|p34;12.5}")
(mknum txt) -> "12.5"

(setq txt "{\\fArial Narrow|b0|i0|c204|p34;1}2{\\fArial Narrow|b0|i0|c204|p34;,}5")
(mknum txt) -> "12.5"

[Кулик Алексей aka kpblc]

> VVA : Думаю, тебе пригодится такое (для определения текущего разделителя):

Код:

[Выделить все]

;|
*    Возвращает значение десятичного разделителя
|;
(defun _kpblc-reg-decimal-separator-get	()
  (vl-registry-read
    "HKEY_CURRENT_USER\\Control Panel\\International"
    "sDecimal"
    ) ;_ end of vl-registry-read
  ) ;_ end of defun

[VVA]

Протестируйте такое. В принципе тоже что и у тебя, но компактнее
;;;Снятие формата с MTEXT
;;; Mtext - строка Мтекта типа "793{\\fArial Narrow|b0|i0|c204|p34;,}44"
;;;Возврат - строка без форматирования

Код:

[Выделить все]

(defun Unformat ( Mtext / text )
  (setq Text "")
   (while (/= Mtext "")
        (cond
          ((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[\\{}]")
            (setq Mtext (substr Mtext 3) Text   (strcat Text Str)))
          ((wcmatch (substr Mtext 1 1) "[{}]")(setq Mtext (substr Mtext 2)))
          ((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[LO`~]")
	   (setq Mtext (substr Mtext 3)))
          ((wcmatch (strcase (substr Mtext 1 2)) "\\[ACFHQTW]")
            (setq Mtext (substr Mtext (+ 2 (vl-string-search ";" Mtext)))))
          ((wcmatch (strcase (substr Mtext 1 2)) "\\P")
            (if (or(= " " (substr Text (strlen Text)))
		   (= " " (substr Mtext 3 1)))
               (setq Mtext (substr Mtext 3))
               (setq Mtext (substr Mtext 3) Text (strcat Text " "))))
	  ((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)))))
	  (t (setq Text (strcat Text (substr Mtext 1 1)) Mtext (substr Mtext 2)))
	  ))
  Text
  )

Пример

Код:

[Выделить все]

(setq txt "{\\fArial Narrow|b0|i0|c204|p34;Воздухозаборная
\\fArial Narrow|b0|i0|c0|p34;\{\\fArial Narrow|b0|i0|c204|p34;решетка \\fArial Narrow|b0|i0|c0|p34;\}
{\\fArial Narrow|b0|i0|c204|p34;900х600 (\\fArial Narrow|b0|i0|c0|p34;h\\fArial Narrow|b0|i0|c204|p34;)
на отм.2,600}")
(unformat txt) -> "Воздухозаборная\nрешетка \n900х600 (h)\nна отм.2,600"

[KAI]

Тестируем в Acad2007:

Код:

[Выделить все]

Command: (unformat txt)
"Воздухозаборная \n;;;решетка  \n;;;900х600 (h) \n;;;на отм.2,600"

Вроде как лишние точки с запятой.

[Олег К.]

А тема оказывается популярная. С утра просмотрел сообщения, спасибо всем, что указали “верный путь”. Придумал свой вариант снятия форматирования с текста, работает с однострочным и многострочным текстом, хотя в большом многострочном возможны косяки (один раз встретилось \\fArial Nar… вместо {\\fArial Nar…), не снимаются метки форматирования типа \n, \P, \L и т.п. Проверял на 2006 и 7 АвтоКАДе. Прошу сильно не бить за отсутствие проверок на ошибки, функция изначально задумывалась для одной цели: перевести текст “793,44” (как он выглядит на экране) в число 793.44 для дальнейших вычислений.

Код:

[Выделить все]

;;; -----------------------------  _Cris-UnfTextStr  -----------------------------
;;; Функция снимает метки форматирования текстовой строки и возвращает вещественное число
;;; если в начале текста цифра(ы), либо число 0.0 если текст начинается с буквы.
;;; Пример:
;;; (_Cris-UnfTextStr "{\\fArial Narrow|b0|i0|c204|p34;321,456}")
;;; Возвращает: 321.456
;;; ------------------------------------------------------------------------------------

(defun _Cris-UnfTextStr (textstr / startfnum endfnum formatstr)
  (setq startfnum 0 endfnum 0)
  (while (not (null startfnum))
    (setq startfnum (vl-string-search "{\\" textstr))
    (if (not (null startfnum))
      (progn ; _1
        (setq endfnum (vl-string-search ";" textstr startfnum))
        (if (not (null endfnum))
          (progn ; _2
            (setq formatstr (substr textstr (1+ startfnum) (1+ (- endfnum startfnum)))
                  textstr (vl-string-subst "" formatstr textstr startfnum)
                  textstr (vl-string-subst "" "}" textstr startfnum))
            (setq endfnum 0 formatstr nil)
          ) ; progn_2
        ) ; if(endnum)
        (setq startfnum 0)
      ) ; progn_1
    ) ; if(startnum)
  ) ; while(not (null startnum)
  (atof (vl-string-translate "," "." textstr))
) ; defun_Cris-UnfTextStr

[Олег К.]

В предыдущем сообщении отредактировал функцию снятия форматирования с текста – в таком виде использую ее в “калькуляторе текста”. В принципе этот калькулятор работает, но хотелось бы улучшить некоторые места. Поэтому очень прошу подсказать ответы на следующие вопросы, или дать ссылки на темы обсуждений (долго ковырял поиском этот форум и на AutoCAD.ru но ничего полезного не выловил).
1. Функция ssget : как избавиться от запроса “Select objects: ” ?
2. Функция initget используется в таком варианте:
(initget "Число Функция Результат Выход X A H D _X A H D X A H D")
(setq oneobj (entsel "\n Укажите текст или [ Число / Функция / Результат / Выход]: "))
- такой initget прописал, когда дал протестировать программу опытному пользователю и мне был задан вопрос “Почему я должен вводить команды только на русском? Может я не знаю какая раскладка включена, должна понимать и английский вариант.” Так вот, есть ли способ попроще (ну или покрасивше) заставить пользователя вводить только нужные мне данные (ткнуть текст или выбрать опцию)?
3. Этот вопрос является продолжением предыдущего. В ответ на запрос функции entsel можно ввести “L” и будет повторен последний выбор. Я то могу сказать юзерам “это не баг, это фича”, но самому же интересно как оно проскакивает мимо initget’a ??
4. Можно ли программно, но не через конструкцию (vl-cmdf "_.-layer" "_U" "имя слоя" "") разблокировать слой? Информацию о состоянии слоя беру из таблицы слоев через (cdr (assoc 70 (tblsearch "LAYER" textlayer))).
Простите, если вопросы покажутся глупыми, я ведь только учусь (а больше спрашивать то и некого) и заранее спасибо за ответы.

Кстати, вопрос Модератору: не пора ли поменять название темы, скажем на “калькулятор текста”, или подобное? Так сказать, чтобы будущие поколения программистов могли быстрее найти нужную информацию.

[Лентяй]

Сообщение от Олег К. 4. Можно ли программно, но не через конструкцию (vl-cmdf "_.-layer" "_U" "имя слоя" "") разблокировать слой? Информацию о состоянии слоя беру из таблицы слоев через (cdr (assoc 70 (tblsearch "LAYER" textlayer)))

Можно средствами ActiveX, о преимуществах которых я здесь уже устал повторять.

Код:

[Выделить все]

(setq lyrs (vla-get-layers (vla-get-ActiveDocument (vlax-get-acad-object))); Получаем объект - коллекцию слоев
      lyr (vla-item lyrs "textlayer")); Получаем объект - слой с именем "textlayer"
(if (= (vla-get-lock lyr) :vlax-true) (vla-put-lock lyr :vlax-false)); Проверяем, заблокирован ли этот слой и снимаемблокировку

[VVA]

1. Функция ssget : как избавиться от запроса “Select objects: ” ?
(ssget "_X" фильтр) http://www.afralisp.net/lispa/lisp19.htm
Самое полное описание в Vlisp'e F1
2. Если речь все-таки идет об опциях команды.
Пусть пользователь объяснит тебе и нам, если он видит приглашение
"Укажите текст или [ Число / Функция / Результат / Выход]: "
Какой английский вариант он имеет ввиду? И почему английский, а не немецкий? Пусть почитает F1->Руководство полизователя->Пользовательский интерфейс->Окно команд->Ввод команд в командной строке->Задание опций команд. Это правило.
3. Вызови команду _MOVE. В ответ на запрос "Выберите объекты:" набери "qwe". Автокад ругнется и выдаст

*Неверный выбор* Требуется точка или Рамка/Последний/Секрамка/БОКС/Все/Линия/РМн-угол/СМн-угол/Группа/Класс/Добавить/ Исключить/Несколько/Текущий/Отменить/Авто/Единственный

Это способы выбора объектов.
То же если в ответ на запрос (entsel) ввести "qwe" получим

*Неверный выбор* Требуется точка или Последний

Последний - он же "_Last". Это не баг, это фича - это норма, просто не все знают.

[ShaggyDoc]

Насчет соблюдения правил VVA прав. Надо придерживаться стандарта Автокада.

Если пользователь введет "русскую" опцию при английской раскладке (вместо "Ч" - "X"), то получит сообщение об ошибке и повторное приглашение. А уж дело программиста обработать эту ситуацию.

Если у пользователя туго с клавиатурным вводом, он должен иметь возможность выбрать из контекстного меню. А уж дело программиста предусмотреть, чтобы контекстное меню автоматически дополнялось нужными опциями.

Предусматривать все варианты неправильной раскладки, да еще и ошибок при написании ("Чило", "Xicla") и т.п. не следует. Иначе программа никогда не будет написана.

А вот Выход лучше делать всегда (за исключением некоторых ситуаций) в качестве действия по умолчанию
"Укажите текст или [Число/Функция/Результат]< Выход>: "

[Diman111]

В тему топика просьба - давно хотел найти но пока не нашел код реализующий следующий набор действий:
есть спецификация -
.............................|......Кол.......|..Масса..|
.............................|...ТР1.|.ТР2..|.............|

Двутавр...................158......259......236

т.е. есть ряды столбцов с массой и количеством
надо в итоге получить общий все каждого изделия ТР1 и ТР2.
путем выделения рамкой всего столца ТР1 - кол-во др рамкой всего столбца масса - в итоге имеем 2 массива которые надо перемножить и сложить.
НО
часть данных может содержать не число а "-" т.е. скажем уголок есть в тр1 а в тр2 его нет - следовательно стоит прочерк.
вот такая просьба

[Олег К.]

Вот что значит неточно поставить вопрос! Исправляюсь:
(princ "\n Выберите текст для изменения: ")
(setq changeobj (entget (ssname (ssget "_:S" '((0 . "*TEXT"))) 0)) textlayer (cdr (assoc 8 changeobj)))
Можно ли избавиться от запроса “Select objects: ” именно в функции ssget ?

>> Лентяй.
Я конечно осознаю, что у ActiveX больше возможностей, но только еще начинаю разбираться в этих функциях (спасибо Н.Н. Полещуку и соавторам, их книги дошли (ощущение что действительно пешком) и до нашего города), хотя функции vla-get-lock не нашел ни в F1 ни в книгах. Как я понял, используется обычная vla-get- к которой добавляется нужное свойство? Может есть у Вас ссылки на документы в сети или форумы где это объясняется подробнее? Благодарю за помощь, буду использовать.

>> VVA и ShaggyDoc.
По поводу русских и английских опций команд. Строчка (initget "Число Функция Результат Выход X A H D _X A H D X A H D") появилась именно из-за того, что пользователь может забыть или не знать (не будете спорить, что такое возможно?) какая раскладка включена. И что бы не беспокоить его сообщениями типа “у вас не та раскладка, переключитесь!” дана возможность ввода на английском, хотя пользователь об этом и не подозревает (короче это и есть “проверка” на ошибочный ввод) С другой стороны, у меня почти весь acad.pgp дополнен русскими вариантами альясов “line” - “L” - “Д” и т.п., так что я посчитал этот вариант полезным.

Если у пользователя туго с клавиатурным вводом, он должен иметь возможность выбрать из контекстного меню. А уж дело программиста предусмотреть, чтобы контекстное меню автоматически дополнялось нужными опциями.

Вот как раз для контекстного ввода и даны в строке запроса (entsel "\n Укажите текст или [ Число / Функция / Результат / Выход]: ") опции в [ ] и через дробь. Далее возникают некоторые сложности: в ACAD2002 по правому клику вызывается контекстное меню с указанными опциями, в ACAD2006 правый клик игнорируется, но при включенном динамическом вводе около курсора висит текст запроса со значком (вроде как раскрывающийся список) при нажатии клавиши Win он раскрывается и доступны опции.
У меня на компе его раскрыть не получается, думаю из-за настройки открытия папок и документов по одному клику и скрывающейся панели Windows.
В связи с этим два вопроса:
1. Как в функции entsel сделать опции доступными сразу (в getkword’e список опций дается уже раскрытый)?
2. В какой сист. переменной пишется включен или отключен динамический ввод?

А вот Выход лучше делать всегда (за исключением некоторых ситуаций) в качестве действия по умолчанию "Укажите текст или [Число/Функция/Результат]< Выход>: "

В этом случае я подумал, что пусть лучше пользователь осознанно выберет “Выход”, чем просто щелкнет Enter’ом. Далее идет проверка на наличие результата и запрашивается подтверждение выхода.

Попробую приложить файл программы, гляньте у кого время есть.
[ATTACH]1160657385.rar[/ATTACH]
Надо же, получилось (ну новичек я еще в сети ).
С нетерпением жду ответов и готов к конструктивной критике.

[VVA]

>Diman111
Пробуй

Код:

[Выделить все]

(defun C:SUMTXT ( / nab pt1 pt2 i col mass SUM h)
(vl-load-com)
(initget 1)
(setq pt1  (getpoint "\nУкажите рамкой столбец количество. Первая точка: "))
(initget 1)  
(setq pt2  (getcorner pt1 "\nВторая точка: "))
(setq nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))  
(if nab
  (progn
  (setq col (mapcar ' vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex nab))))
	col (vl-sort col '(lambda(x y)
	       (> (cadr (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint x))))
	       (cadr (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint y))))))))
  ));_if
(initget 1)
(setq pt1  (getpoint "\nУкажите рамкой столбец МАССА. Первая точка: "))
(initget 1)  
(setq pt2  (getcorner pt1 "\nВторая точка: "))
(setq nab nil nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))  
(if nab
(setq mass (mapcar ' vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex nab))))
	mass (vl-sort mass '(lambda(x y)
	       (> (cadr (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint x))))
	       (cadr (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint y))))))))
  );_if
(if (and col mass)
  (if (= (length col)(length mass))
    (progn
      (setq i 0 SUM 0)
      (foreach item col
	(princ "\nCol=")(princ (atof(vla-get-TextString item)))
	(princ " Mas=")(princ (atof(vla-get-TextString (nth i mass))))
	(setq SUM (+ SUM (* (atof(vla-get-TextString item))
			    (atof(vla-get-TextString (nth i mass)))))
	      i (1+ i)))
        (initget 1)
        (setq pt1 (getpoint "\nТочка отрисовки текста: "))
        (if (zerop (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE")))))
        (COMMAND "_TEXT" pt1 (vla-get-Height (car col)) "0" (rtos SUM 2 3)) ;_ нулевая высота текста Будет запрос высоты
        (COMMAND "_TEXT" pt1 "0" (rtos SUM 2 3))  ;_ фиксированнная высота Запроса не будет
        );_end of if
      )
    (alert "Не совпадает кол-во текста в столбцах!") ))
(princ));_defun

Если данных нет, должно быть хоть что-то: "-", "нет" - любой текст.
Разделитель дробной части - точка, а не запятая (если нужно, можно подправить)

[Лентяй]

Сообщение от Олег К. >> Лентяй. Я конечно осознаю, что у ActiveX больше возможностей, но только еще начинаю разбираться в этих функциях (спасибо Н.Н. Полещуку и соавторам, их книги дошли (ощущение что действительно пешком) и до нашего города),..

Тут, как всегда, главное нАчать. А когда раскусите все прелести - дальше само поцдет только так [sm200]

...хотя функции vla-get-lock не нашел ни в F1 ни в книгах. Как я понял, используется обычная vla-get- к которой добавляется нужное свойство? Может есть у Вас ссылки на документы в сети или форумы где это объясняется подробнее? Благодарю за помощь, буду использовать.

Вы поняли все правильно - это сокращенная форма записи выражения

Код:

[Выделить все]

 vlax-get-property object 'property_name

А объяснение имеется у того же Полещука - буквально на второй странице раздела ActiveX. Так что читайте мудрую книгу внимательно, и будет вам щастя. Успехов [sm804]

[ShaggyDoc]

В этом случае я подумал, что пусть лучше пользователь осознанно выберет “Выход”, чем просто щелкнет Enter’ом. Далее идет проверка на наличие результата и запрашивается подтверждение выхода.

Вот в таких местах крепко думать надо. В стандартном интерфейсе, как правило, за редкими исключениями, пустой ввод ("просто щелкнет Enter'ом") приводит к завершению команды.

Если у вас выход по опции, то непонятно, глядя на командную строку, к чему же приведет пустой ввод (в текст программы я не заглядываю).

Возможно, в конкретном случае, выход нужен именно по опции, но тогда в командной строке должно быть отображено(в <Что будет при пустом вводе>), что же именно произойдет по умолчанию. Скорее всего это должна быть одна из популярных опций. Хотя самая популярная - как раз Выход.

И совсем не надо запрашивать дополнительное подтверждение выхода. Такая "мания величия" программ ("как, неужели Вы хотите меня покинуть") очень мешает в реальной работе.

[VVA]

(setq changeobj (entget (ssname (ssget "_:S" '((0 . "*TEXT"))) 0)) textlayer (cdr (assoc 8 changeobj))) Можно ли избавиться от запроса “Select objects: ” именно в функции ssget ?

НЕТ

в ACAD2006 правый клик игнорируется

_options Закладка Пользовательские - настрой правый клик.

при нажатии клавиши Win он раскрывается и доступны опции

Раскрывается при нажатии "стрелки вниз"

В этом случае я подумал, что пусть лучше пользователь осознанно выберет “Выход”, чем просто щелкнет Enter’ом. Далее идет проверка на наличие результата и запрашивается подтверждение выхода

Для ф-ции entsel можно отделить мух и котлеты (промах и нажатие ENTER) Ниже пример, выход по нажатию ENTER.
Обрати внимание, что ((null oneobj) стоит выше ((listp oneobj) в cond, т.к. nil тоже список.

Код:

[Выделить все]

(setq next t)
(while next
  (initget "Число Функция Результат Выход X A H D _X A H D X A H D")
  (setq oneobj (entsel "\n Укажите текст или [ Число / Функция / Результат / Выход] <Выход>: "))
 (cond
   ((member oneobj '("Число" "X"))
    (alert "\nВы выбрали опцию Число"))
   ((member oneobj '("Функция" "A"))
    (alert "\nВы выбрали опцию Функция"))
   ((member oneobj '("Результат" "H"))
    (alert "\nВы выбрали опцию Результат"))
   ((member oneobj '("Выход" "D"))
    (alert "\nВы выбрали опцию Выход"))
   ((null oneobj) ;_Промахнулся или нажал ENTER?
    (setq ern (getvar "ERRNO"))
    (cond  ((= ern 7) ;;;Пустой выбор
	    (alert "Вы промахнулись\nНичего не выбрано"))
           ((= ern 52) ;;;Клавиша Ввод(выход)
	    (alert "Вы нажали ENTER\nДо свидания")(setq next nil)) 
	   (t (alert (strcat  "Номер ошибки ERRNO=" (itoa ern))))
	   )
    )
   ((listp oneobj)
    (alert (strcat "\nВы выбрали " (cdr(assoc 0 (entget (car oneobj)))))))

   (t nil)
   ))

Может есть у Вас ссылки на документы в сети или форумы где это объясняется подробнее? Благодарю за помощь, буду использовать.

http://www.jtbworld.com/lisp/layer-state.htm
http://www.menziengineering.ch/Downloads/Download.htm
http://www.arcada.com.ua/forum/viewf...c4e108effc725f
Там много всего вкусного

[Diman111]

>VVA
Спасибо большое ))
с разделителями разберемся

[Олег К.]

>> ShaggyDoc.

Вот в таких местах крепко думать надо. В стандартном интерфейсе, как правило, за редкими исключениями, пустой ввод ("просто щелкнет Enter'ом") приводит к завершению команды.

Это Вы про какой стандартный интерфейс: AutoCAD’a или RuCAD’a ? Если автокадовский, то взять хотя бы команды LINE и COPI – в первом запросе не написано, что они сделают при пустом вводе, но ведь делают!!

Если у вас выход по опции, то непонятно, глядя на командную строку, к чему же приведет пустой ввод (в текст программы я не заглядываю). Возможно, в конкретном случае, выход нужен именно по опции, но тогда в командной строке должно быть отображено(в <Что будет при пустом вводе>), что же именно произойдет по умолчанию. Скорее всего это должна быть одна из популярных опций. Хотя самая популярная - как раз Выход.

Просто я взял за правило: если программа ничего не делает при пустом вводе – не писать <Действие при пустом вводе> (ну в самом деле, не писать же <Ничего>). В данном случае
(entsel "\n Укажите текст или [ Число / Функция / Результат / Выход]: ")
по нажатию ENTER или SPACE программа ничего не делает, просто будет повторен запрос.

И совсем не надо запрашивать дополнительное подтверждение выхода. Такая "мания величия" программ ("как, неужели Вы хотите меня покинуть") очень мешает в реальной работе.

А это не "мания величия". В какой-то момент пользователь хочет выйти из программы и набирает “Выход” или просто “В”, тогда :
- если проводились вычисления и есть результат – появится дополнительный запрос (getkword "\n Вы хотите выйти без сохранения результата вычислений? [Да / Нет] <Нет> :") ;
- если нет результата, либо он только что выведен на лист – выход без вопросов.
Мне кажется, так будет правильнее. В принципе, можно и не смотреть текст проги (лучше не смотрите, а то мне некуда помидоры складировать), достаточно запустить и погонять несколько раз. Наши “тетки” сразу поняли, что от них требуется в запросах.

>> ShaggyDoc и VVA.
Вот правда так и не решил: выносить опцию выхода на пустой ввод или нет "\n Укажите текст или [ Число / Функция / Результат ] <Выход>: "? Если выносить, то придется ставить анализ ERRNO, как рекомендует VVA.

Спасибо за ссылки, сижу изучаю :shock: . Чувствую себя мартышкой, изобретающей велосипед.

[ShaggyDoc]

Это Вы про какой стандартный интерфейс: AutoCAD’a или RuCAD’a ? Если автокадовский, то взять хотя бы команды LINE и COPI – в первом запросе не написано, что они сделают при пустом вводе, но ведь делают!!

Так в Автокаде много ляпов встречается. В том числе неоднообразное оформление команд. Дисциплина трудовая у них слабовата...

Просто я взял за правило: если программа ничего не делает при пустом вводе – не писать <Действие при пустом вводе> (ну в самом деле, не писать же <Ничего>). В данном случае (entsel "\n Укажите текст или [ Число / Функция / Результат / Выход]: ") по нажатию ENTER или SPACE программа ничего не делает, просто будет повторен запрос.

Про то и речь, что плохое "правило" - возможность действия, причем стандартного есть, а не делается ничего. Пользователь-то не знает, что повторен запрос. Он думает, что почему-то ничего не происходит.

[Олег К.]

Ладно, критику осознал. Поставлю "Выход" на пустой ввод.
А как вы поступаете в таком случае, когда пустой ввод возможен но по нему ничего делаться не должно?
Можно конечно обрабатывать ERRNO (учесть не только Enter), но все равно ведь будет повторена строка запроса. Придется выдать пользователю сообщение "Недопустимый ввод", а то и расписать сообщения по каждой из ошибок. Ох-хо-хох. Был у меня такой опыт: составил програмку для подсчета длин объектов - заняла 25 строк с комментариями, поставил в нее обработку ошибок и Escape - в результате 111 строк. Вот и стал задумываться: когда это нужно, а когда - нет.

Кажись мы отклонились от темы, но надеюсь это простительно?

[water]

может кто-нить поможет и мне с программкой? суть её в том, что бы в определённом порядке блоки расставлять. Если у знатоков программирования есть время и желание стучите icq 190103321. Заранее благодарна

[DEM]

Сообщение от water может кто-нить поможет и мне с программкой? суть её в том, что бы в определённом порядке блоки расставлять. Если у знатоков программирования есть время и желание стучите icq 190103321. Заранее благодарна

Сейчас все знатоки ЛИСПА кинутся вам помогать.
Отключайте сразу АСЬКУ, а то комп от перегрузки сломается.

[Кулик Алексей aka kpblc]

Спробуй, уже давно я его не проверял.

Код:

[Выделить все]

;|=============================================================================
*    Функция расстановки блоков по "матрице".
*    Параметры вызова:
*	delta	- шаг в единицах чертежа между блоками (одинаковый по x и по y)
*	max_col	- максимальное количество колонок в создаваемой матрице
*    Примеры вызова:
(_kpblc-block-replacer 10 10)	; сделать матрицу с шагом 10 мм, не более 10
				; блоков в строке
(_kpblc-block-replacer 100 10)	; шаг 100, не больше 10 блоков в строке.
=============================================================================|;
(defun _kpblc-block-replacer (delta      max_col	  /	     item
			    counter    row	  col	     temp_ins_point
			    )
  (setq	selset	(ssget '((0 . "INSERT")))
	counter	0
	row	0
	col	0
	) ;_ end of setq
  (repeat (sslength selset)
    (setq item		 (ssname selset counter)
	  counter	 (1+ counter)
	  temp_ins_point (list
			   (atof (rtos (* delta col)))
			   (atof (rtos (* delta row)))
			   0.0
			   ) ;_ end of list
	  col		 (1+ col)
	  ) ;_ end of setq
    (if	(> col max_col)
      (setq col	0
	    row	(1+ row)
	    ) ;_ end of setq
      ) ;_ end of if
    ;;(vla-put-insertionpoint (vlax-ename->vla-object item) temp_ins_point)
    (_kpblc-ent-modify-autoregen item 10 temp_ins_point t)
    ) ;_ end of repeat
  ) ;_ end of defun

;|=============================================================================
*    Функция модификации указанного бита примитива
*    Параметры вызова:
*	entity	- примитив, полученный через (entsel), (entlast) etc
*	bit	- dxf-код, значение которого надо установить
*	value	- новое значение
*	regen	- выполнять или нет регенерацию примитива сразу. t/ nil
*    Примеры вызова:
(_kpblc-ent-modify (entlast) 8 "0" t)	; перенести последний примитив на слой 0
(_kpblc-ent-modify (entsel) 62 10 nil)	; установить выбранному примитиву цвет 10
*    Возвращаемое значение:
*	примитив с модифицированным dxf-списком. Примитив перерисовывается в
* зависимости от значения ключа ext_regen
=============================================================================|;
(defun _kpblc-ent-modify-autoregen (ent	       bit	  value	     ext_regen
				    /	       ent_list	  old_dxf    new_dxf
				    layer_dxf70
				    )
  (setq ent (_kpblc-conv-ent-to-ename ent))
  (if (not
	(and
	  (or
	    (= (strcase (cdr (assoc 0 (entget ent))) nil) "STYLE")
	    (= (strcase (cdr (assoc 0 (entget ent))) nil) "DIMSTYLE")
	    (= (strcase (cdr (assoc 0 (entget ent))) nil) "LAYER")
	    ) ;_ end of or 
	  (= bit 100)
	  ) ;_ end of and 
	) ;_ end of not 
    (progn
      (setq ent_list (entget ent)
	    new_dxf  (cons bit
			   (if (and (= bit 62) (= (type value) 'str))
			     (if (= (strcase value) "BYLAYER")
			       256
			       0
			       ) ;_ end of if 
			     value
			     ) ;_ end of if 
			   ) ;_ end of cons 
	    ) ;_ end of setq 
      (if (not (equal new_dxf (setq old_dxf (assoc bit ent_list))))
	(progn
	  (entmod (if old_dxf
		    (subst new_dxf old_dxf ent_list)
		    (append ent_list (list new_dxf))
		    ) ;_ end of if 
		  ) ;_ end of entmod
	  (if ent_regen
	    (entupd ent)
	    (redraw ent)
	    ) ;_ end of if
	  ) ;_ end of progn 
	) ;_ end of if 
      ) ;_ end of progn 
    ) ;_ end of if 
  ent
  ) ;_ end of defun


(defun c:kpblc-block-replacer (/ delta max_col)
  (setq	delta	(getdist "\nУкажите расстояние между блоками : <25> ")
	max_col	(getint "\nУкажите максимальное количество столбцов : <10> ")
	) ;_ end of setq
  (if (not delta)
    (setq delta 25)
    ) ;_ end of if
  (if (not max_col)
    (setq max_col 10)
    ) ;_ end of if
  (_kpblc-block-replacer delta max_col)
  ) ;_ end of defun

[water]

Сообщение от DEM Сообщение от water может кто-нить поможет и мне с программкой? суть её в том, что бы в определённом порядке блоки расставлять. Если у знатоков программирования есть время и желание стучите icq 190103321. Заранее благодарна Сейчас все знатоки ЛИСПА кинутся вам помогать. Отключайте сразу АСЬКУ, а то комп от перегрузки сломается.

понимаю, что не все, но вруг кто-нибудь поможет, на свете много людей ...., а аська у меня спецом для общения по вопросам работы )

[water]

создание матрицы не совсем подходит, хочу, что б блоки рассавлялись в соответствии с размерами конктного помещения

[Кулик Алексей aka kpblc]

water, я все понимаю, но телепат аппликайшн я снес вместе со старой машиной. Какая была задача - такое и было решение. Блоки "в определенном порядке", да еще и внутри помещений и ADT не расставляет. И потом, что значит "в определенном порядке"? Кто и как определяет этот порядок?

[Лентяй]

Сообщение от kpblc water, я все понимаю, но телепат аппликайшн я снес вместе со старой машиной. Какая была задача - такое и было решение. Блоки "в определенном порядке", да еще и внутри помещений и ADT не расставляет. И потом, что значит "в определенном порядке"? Кто и как определяет этот порядок?

Начало программы должно быть таким:

Код:

[Выделить все]

(defun C:Bloki_marsh_po_mestam ( )

[DEM]

Код:

[Выделить все]

(defun C:Bloki_marsh_po_mestam ( )

[/quote]
Уау Лентяй ентот код надо вписывать в АНАЛЫ AutoLispa
Мне до такого щагать и шагать

[Лентяй]

Сообщение от DEM Уау Лентяй ентот код надо вписывать в АНАЛЫ AutoLispa Мне до такого щагать и шагать

DEM, в АНАЛЫ можно, разве что, запердолить. А вписать можно только в АННАЛЫ.

[water]

Жаль, что так никто и не отозвался ((

[Кулик Алексей aka kpblc]

Почему же? А посты с 57 и дальше? Ты сама-то можешь сказать, чего тебе надо? Только не общими словами.
btw, сделать "одну большую красную кнопку" с надписью "чтоб было клево" тебе не удастся. Максимум - большая зеленая кнопка с надписью "тебе уже клево"
---
Добавлено: Поправил пост (обшибся с обращением).

[water]

Ну, значит хочу:
1- расстановку датчиков в соответстии с НПБ
2- расстановку оросителей с разводкой трубопровода в соответствии с НПБ
3- .... большую шоколадку и больше оперативки в мой рабочий комп

зы: как уже говорила, есть недоработанные решения, сама ничерта в етом не понимаю, но знаю где работает некорректно

[Кулик Алексей aka kpblc]

Ыыыы... Что такое НПБ - лично я БМП. Могу обеспечить только п.3.1

[DEM]

Ну если
water
Ну, значит хочу:

1- расстановку датчиков в соответстии с НПБ 2- расстановку оросителей с разводкой трубопровода в соответствии с НПБ

то вам нужно СПМ по НПБ

[water]

НПБ- нормы пожарной безопасности, типа датчик от стены на 4,5 м , между датчиками 9 м , при высоте помещения 3,5 м, одним оросителем защищается площать 12 м2

я бы на вашем месте , уважаемый kpblc, с такое лёгкостью не утверждала по поводу пункта 3.1 , по почте шоколадки не всегда доходят

[Лентяй]

[quote="water"]НПБ- нормы пожарной безопасности, типа датчик от стены на 4,5 м , между датчиками 9 м , при высоте помещения 3,5 м, одним оросителем защищается площать 12 м2[quote]
Короче, девушка хочут заполучить решение системы УЛП средствами ЛИСП, которые, будучи интегрированы в САПР, эмулируются в большую розовую кнопку... Господа, тута ЛНП Канторович не пробегал?

[Apelsinov]

Сообщение от water НПБ- нормы пожарной безопасности, типа датчик от стены на 4,5 м , между датчиками 9 м , при высоте помещения 3,5 м, одним оросителем защищается площать 12 м2

На самом деле девушка подняла хорошую тему, вполне возможно, что расстановку спринклерных оросителей в плане по помещениям можно попытаться автоматизировать. Жаль только не смогла толком объяснить что же конкретно она хочет (ну с шоколадкой вроде разобрались).
water, попробуйте объяснить людям что конкретно вы хотите, подробно, с примерами и цитатами из нормативов, тогда, вас наверняка поймут и помогут. А еще интересно о каких имеющихся у Вас наработанных решениях идет речь, и что в них вас не устраивает.
А тему лучше переместить отсюда в отдельную, а то бардак.

[water]

Я не знаю как перевести тему в отдельную.
Попробую объяснить подробнее хотя бы по одному пункту что-же я хочу. Есть план помещений в нужном масштабе. Есть определённого вида блоки я рамкой выделяю площадь помещения и на этой площади блоки ставятся равномерно в нужном количестве. Блоки разные и требования к их расстановке тоже разные. Иногда есть необходимость ставить блоки попарно. Если кто-то может помочь подробно расскажу что и как должно стоять

[Олег К.]

>> water
В самом деле, вопрос поставлен интересный, попробуйте создать новую тему (в низу страницы есть кнопочка "Новая тема").

Если кто-то может помочь подробно расскажу что и как должно стоять

Вы, главное, объясните подробно, что нужно - больше народа думать будет. А там уж кто додумается, тот и поможет. Кстати, уточните: вам нужна расстановка только блоков датчиков/оросителей или еще и разводка электро/водопроводной сети (в начале вопрос был о сети).
Пожалуйста, напишите какими нормативами Вы пользуетесь, да и "наработанные решения" неплохо бы сюда закинуть, если объем позволяет.

[water]

см. тему "В помощь проектировщикам ОПС"

[Juss_00]

Удалил

[gomer]

INCDEC - http://dwg.ru/dnl/3716

[СерJант]

Сообщение от _Andre_ Вот так тогда Код: [Выделить все] (defun ed_wrdcount (/ descript fnam txtstr txtspace lst lstp tvst) (vl-load-com) (if (setq lst (ssget (list '(0 . "TEXT") (cons 410 (getvar "ctab"))))) (progn (setq txtspace (vla-objectidtoobject (vla-get-activedocument (vlax-get-acad-object)) (vla-get-ownerid (vlax-ename->vla-object (ssname lst 0)) ) ;_ end of vla-get-ownerid ) ;_ end of vla-ObjectIDToObject ) ;_ end of setq (setq lst (mapcar '(lambda (x) (cdr (assoc 1 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex lst) ) ;_ end of mapcar ) ;_ end of vl-remove-if ) ;_ end of mapcar ) ;_ end of setq (foreach i lst (if (not (assoc i lstp)) (setq lstp (cons (list i (length (vl-remove-if-not '(lambda (x) (= i x)) lst ) ;_ end of vl-remove-if-not ) ;_ end of length ) ;_ end of list lstp ) ;_ end of cons ) ;_ end of setq ) ;_ end of if ) ;_ end of foreach (setq txtstr (apply 'strcat (mapcar '(lambda (x) (strcat (car x) " - " (itoa (cadr x)) "\\P") ) (vl-sort lstp '(lambda (y1 y2) (> (car y1) (car y2)))) ) ;_ end of mapcar ) ;_ end of apply ) ;_ end of setq (if (setq tvst (getpoint "\nSpecify start point of text:")) (vla-addmtext txtspace (vlax-3d-point tvst) 10000 txtstr) ) ;_ end of if ) ;_ end of progn ) ;_ end of if (princ) )

Все равно сортирует не корректно
например:
Кр40 - 1
Кр4 - 1
Кр39 - 1
***
Кр32 - 1
Кр31 - 1
Кр30 - 1
Кр3 - 1
Кр29 - 1
Кр28 - 1
***
Кр21 - 1
Кр20 - 1
Кр2 - 1
Кр19 - 1
Кр18 - 1
***
Кр12 - 1
Кр11 - 1
Кр10 - 1
Кр1 - 1

можно как то это исправить?

[Сергей812]

так и в любом другом языке отсортирует аналогично) Хотите корректно - либо выравнивайте разрядность (к примеру, вместо Кр4 формируйте Кр04), либо по другому храните данные - отдельно строки и числа

[Кулик Алексей aka kpblc]

Есть еще как минимум три варианта:
- если префикс один и тот же, написать свой лиспик
- если префикс может отличаться, то писать свой парсер
- найти (например, на theswamp.org) готовый код (кажется, от Lee Mac)

[VVA]

Сообщение от Кулик Алексей aka kpblc найти (например, на theswamp.org) готовый код (кажется, от Lee Mac)

Здесь http://www.theswamp.org/index.php?topic=16564.0 и здесь http://www.cadtutor.net/forum/showth...nge-list/page2

Сообщение от СерJант можно как то это исправить?

Так

Код:

[Выделить все]

(defun ed_wrdcount (/ descript fnam txtstr txtspace lst lstp tvst)
  (vl-load-com)
  (if
    (setq lst (ssget (list '(0 . "TEXT") (cons 410 (getvar "ctab")))))
     (progn
       (setq txtspace (vla-objectidtoobject
			(vla-get-activedocument (vlax-get-acad-object))
			(vla-get-ownerid
			  (vlax-ename->vla-object (ssname lst 0))
			) ;_ end of vla-get-ownerid 
		      ) ;_ end of vla-ObjectIDToObject 
       ) ;_ end of setq 
       (setq lst (mapcar '(lambda (x) (cdr (assoc 1 (entget x))))
			 (vl-remove-if
			   'listp
			   (mapcar 'cadr
				   (ssnamex lst)
			   ) ;_ end of mapcar 
			 ) ;_ end of vl-remove-if 
		 ) ;_ end of mapcar 
       ) ;_ end of setq 
       (setq lst (SortStringWithNumberAsNumber  lst nil))
       (foreach	i lst
	 (if (not (assoc i lstp))
	   (setq lstp
		  (cons
		    (list i
			  (length
			    (vl-remove-if-not
			      '(lambda (x) (= i x))
			      lst
			    ) ;_ end of vl-remove-if-not 
			  ) ;_ end of length 
		    ) ;_ end of list 
		    lstp
		  ) ;_ end of cons 
	   ) ;_ end of setq 
	 ) ;_ end of if 
       ) ;_ end of foreach 
       (setq txtstr
	      (apply
		'strcat
		(mapcar
		  '(lambda (x)
		     (strcat (car x) " - " (itoa (cadr x))  "\\P")
		   )
		 ;;; (vl-sort lstp '(lambda (y1 y2) (> (car y1) (car y2))))
		 (reverse lstp)
		) ;_ end of mapcar 
	      ) ;_ end of apply 
       ) ;_ end of setq 
       (if
	 (setq tvst (getpoint "\nSpecify start point of text:"))
	  (vla-addmtext txtspace (vlax-3d-point tvst) 10000 txtstr)
       ) ;_ end of if 
     ) ;_ end of progn 
  ) ;_ end of if 
  (princ)
)
;;Published http://www.theswamp.org/index.php?topic=16564.0
;;By VVA --  05.20.07 mods by CAB
;;Usage (SortStringWithNumberAsNumber '("A9" "A1" "A10" "B11" "B2" "B05") nil)
;;With ignore case (SortStringWithNumberAsNumber '("A9" "A1" "A10" "B11" "B2" "B05") t)
;;  CAB added Ignore Case Flag as an argument
;;Return ("A1" "A9" "A10" "B2" "B05" "B11")
;;;ListOfString - список строк
;;; IgnoreCase - t (игнорировать) или nil (нет) регистр символов
(defun SortStringWithNumberAsNumber (ListOfString IgnoreCase / NorStrs count)
;;;Function Normalize (add 0 befor number) number in string
;;; Count normalize symbols set in variable count
;;; CAB added count as an argument
  (defun NormalizeNumberInString (str count / ch i pat ret buf)
    (setq i   0
          pat '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
          ret ""
    ) ;_ end of setq
    (while (/= (setq ch (substr str (setq i (1+ i)) 1)) "")
      (if (vl-position ch pat)
        (progn
          (setq buf ch) ;_ end of setq
          (while
            (vl-position (setq ch (substr str (setq i (1+ i)) 1)) pat)
             (setq buf (strcat buf ch))
          ) ;_ end of while
          (while (< (strlen buf) count) (setq buf (strcat "0" buf)))
          (setq ret (strcat ret buf))
        ) ;_ end of progn
      ) ;_ end of if
      (setq ret (strcat ret ch))
    ) ;_ end of while
    ret
  ) ;_ end of defun
  ;;-------------------------------------------------
  ;;  function to Count the longest number in string 
  ;;  CAB added to get the correct COUNT
  (defun getcount (lst / count pat)
    (setq count 0)
    (setq pat '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
    (mapcar
      '(lambda (str / i maxlen ch)
         (setq i 0 maxlen 0)
         (while (/= (setq ch (substr str (setq i (1+ i)) 1)) "")
           (if (vl-position ch pat) ; number
             (setq maxlen (1+ maxlen))
             (setq count  (max count maxlen) maxlen 0)
           )
         )
	 (setq count  (max count maxlen)) ;_<<< ADD 21.06.2007 by 
       )
      Lst
    )
    count
  )
  ;;===============================================
  (setq count   (GetCount ListOfString)
        NorStrs (mapcar '(lambda (x) (NormalizeNumberInString x count))
                        ListOfString)
  )
  (and IgnoreCase (setq NorStrs (mapcar 'strcase NorStrs)))
  (mapcar '(lambda (x) (nth x ListOfString)) (vl-sort-i NorStrs '<))
)

[СерJант]

VVA, спасибо большое!!! То что надо! Премного благодарен