Возникла необходимость в суммировании большого количества чисел и забивать каждое число в формулу очень нудно и долго

Макс Тал. · 10.06.2006, 16:52

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

favorite · 10.06.2006, 19:38

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

favorite · 10.06.2006, 19:58

Код:

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

; автор Зурабян Давид Артемович
; Программа сложения чисел
(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 · 13.06.2006, 09:19

Код:

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

(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 · 01.08.2006, 14:44

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

Кулик Алексей aka kpblc · 01.08.2006, 14:53

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

Код:

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

(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 · 01.08.2006, 15:12

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

_Andre_ · 01.08.2006, 15:23

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

Код:

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

(ed_wrdcount)

и жми ентер.

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

Код:

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

^c^c(ed_wrdcount)

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

Om81 · 01.08.2006, 15:34

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

_Andre_ · 01.08.2006, 15:50

Вот так тогда

Код:

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

(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 · 01.08.2006, 16:01

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

Тим · 09.08.2006, 22:01

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

Лентяй · 10.08.2006, 07:18

Ох, уж эти 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

Тим · 12.08.2006, 14:50

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

Лентяй · 13.08.2006, 01:40

Цитата:

Сообщение от Тим

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

Потому и не решаем, что не круто и, стало быть, неинтересно. :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

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

Тим · 13.08.2006, 14:25

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

pyatifan · 13.08.2006, 20:00

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

Код:

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

(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

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

Лентяй · 14.08.2006, 02:31

Цитата:

Сообщение от Тим

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

В каком именно месте эта скотина смеет ругацца :?:

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

Цитата:

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

Тим · 14.08.2006, 09:30

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

Лентяй · 14.08.2006, 09:53

У меня 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]

10.06.2006, 16:52		#1
Возникла необходимость в суммировании большого количества чисел и забивать каждое число в формулу очень нудно и долго Макс Тал. строитель СПб. Регистрация: 13.03.2005 Сообщений: 216 Кто поможет воплотить идею в реальность? Нужен лисп. Охото чтобы команда спрашивала 1. Выберите числа, которые необходимо сложить. 2.После выделения запрос на место размещения результата. 3. Вставка результата. Возникла необходимость в суммировании большого количества чисел и забивать каждое число в формулу очень нудно и долго. У меня есть лисп который прибавляет к выделенным числам величину, которую указываешь в командной строке при запросе.
Просмотров: 30221

Опции темы	Поиск в этой теме
	Поиск в этой теме: Расширенный поиск