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

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Групирование строк в таблице

Групирование строк в таблице

Ответ
Перейти к новому Перейти к новому  
Поиск в этой теме
Непрочитано 20.04.2012, 13:01 #1
Групирование строк в таблице
Positron
 
Регистрация: 25.06.2009
Сообщений: 147
Прошу помощи у программистов, нужен лисп для группировки подобных цифр в столбике таблицы. Во вложении подробное описание.
[IMG]http://s019.***********/i611/1204/be/f84f5d120fc5.jpg[/IMG]


Описание:
Исходные - у нас есть таблица, с несколькими колонками.
1. Требуется сгруппировать строки по заданной колонке.
2. Необходимо суммировать колонки в строк для каждой группы с удалением всех строк групп кроме 1й строки каждой группы.
3. Чистим таблицу от пустых строк.

P.S. И если можно чтоб по умолчанию делся лисп сразу 3 пункта, но можно было и указывать до 1го или до 2го ...
как бы запрос:
-"Делать 3 действия?:3" (только нажать Enter надо)
-"Делать 3 действия?:" ( соотвецтвено вводим другое значение если необходимо)

Вложения
Тип файла: dwg
DWG 2007		 Пример 1.dwg (126.1 Кб, 2249 просмотров)

Последний раз редактировалось Кулик Алексей aka kpblc, 22.04.2012 в 17:29.
Просмотров: 8484
 
Непрочитано 20.04.2012, 13:24
#2
Олег (jr.)

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

Посмотри здесь
http://forums.augi.com/showthread.ph...=1#post1168693
Олег (jr.) вне форума  
 
Автор темы   Непрочитано 20.04.2012, 14:34
#3
Positron


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

Цитата:
Сообщение от Олег (jr.) Посмотреть сообщение
там чуток нето, блоки и выкусывание атрибутов блока в таблицу.
Мне над сортировка и суммирование ... я просто хз как программно реализовать сие чудо
Positron вне форума  
 
Непрочитано 20.04.2012, 19:30
#4
Do$

AutoCAD/Civil3D LISP/C#
 
Регистрация: 15.08.2008
Санкт-Петербург
Сообщений: 1,701
Отправить сообщение для Do$ с помощью Skype™

Вот взять бы первое сообщение - и в FAQ. В качестве примера того, как надо описывать свои просьбы
Positron,
Do$ вне форума  
 
Автор темы   Непрочитано 20.04.2012, 20:10
#5
Positron


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

Цитата:
Сообщение от Do$ Посмотреть сообщение
Вот взять бы первое сообщение - и в FAQ. В качестве примера того, как надо описывать свои просьбы
Positron,
м... исходя из того сколько мне помогли на форуме могу посодействовать если надо
Positron вне форума  
 
Непрочитано 20.04.2012, 21:25
#6
gomer

строю, ломаю
 
Регистрация: 03.04.2008
Украина
Сообщений: 5,515

похожая тема
gomer вне форума  
 
Непрочитано 20.04.2012, 23:24
#7
Олег (jr.)

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

Попробуй вот это
Код:
[Выделить все] 
;;--------------------------------------------------------------------;;
(defun sum-and-groupby_qty (lst num / count countdata elem match tmp)
  
(while lst
  
(setq tmp (car lst))

(setq match (vl-remove-if-not '(lambda(x)(eq (nth num x)(nth num tmp) ))

					  lst))

(setq count (apply '+ (mapcar 'atoi (mapcar 'last  match))))
  
(setq elem (subst (itoa count) (last tmp)  tmp))
  
(setq countdata (cons elem countdata))

(setq lst (vl-remove-if '(lambda(x)(eq (nth num x)(nth num tmp) ))

					  lst))
  )
(vl-sort countdata '(lambda(a b)(< (nth num a)(nth num b))))
  
  )
;;---------------------------------------------------------------------;;
(defun get-table-content (tbl / col cols data datum row rows start tmp)

  (setq	cols  (vla-get-columns tbl)
	rows  (vla-get-rows tbl)
	start rows
	)
  (if (eq :vlax-true (vla-get-titlesuppressed tbl))
    (setq rows (1- rows))
  )
  (if (eq :vlax-true (vla-get-headersuppressed tbl))
    (setq rows (1- rows))
  )
  (setq row (- start rows))
  (repeat rows
    (setq col 0)
    (repeat cols
      (setq datum (vla-gettext tbl row col))
      (setq tmp (cons datum tmp))
      (setq col (1+ col))
    )
    (setq data (cons (reverse tmp) data))
    (setq tmp  nil)
    (setq row  (1+ row))
    )

  (reverse data)
)
;;----------------------------   main part   --------------------------------;;


(defun C:GRPT  (/ cnt col cols data ent idx n num row rows tabledata tbl tmp)
  
(setq ent (entsel "\nSelect table :"))

(setq idx (getint "\nEnter a column number :"))

(setq idx (1- idx))

(setq tbl (vlax-ename->vla-object (car ent)))
  
 (setq tabledata (cddr (get-table-content tbl)))

(setq rows (vla-get-rows tbl))

(setq cols (vla-get-columns tbl))

(setq row 2)

(vla-put-regeneratetablesuppressed tbl :vlax-true)

(setq tabledata (sum-and-groupby_qty tabledata idx))

(setq n 0)

(setq data nil)

(foreach x  tabledata

  (setq x (append (list (itoa (+ n 1))) (cdr x)))

  (setq data (cons x data))

  (setq n (1+ n))
  )

(setq data (reverse data))

(setq row 2)

  (setq num (length data))
  
(setq cnt (+ rows num))
  
(repeat num

  (setq tmp (car data))
  
(vla-InsertRowsAndInherit tbl row (- row 1) 1)

  (setq col 0)

  (while (< col cols)

    (vla-settext tbl row col (nth col tmp))

    (setq col (1+ col))
    )
  (setq row (1+ row))

  (setq data (cdr data))
  )
   
  (setq rows (vla-get-rows tbl))
  
  (vla-deleterows tbl (+ num 2)(- rows num))
  
(vla-put-regeneratetablesuppressed tbl :vlax-false)

(princ)
  
  )

(prompt "\n\t---\tStart command with GRPT\t---\n")
(prin1)
 (or (vl-load-com))
(princ)
~'o'~
Последний раз редактировалось Олег (jr.), 20.04.2012 в 23:35.
Олег (jr.) вне форума  
 
Автор темы   Непрочитано 21.04.2012, 15:22
#8
Positron


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

Цитата:
Сообщение от Олег (jr.) Посмотреть сообщение
Попробуй вот это
Код:
[Выделить все] 
;;--------------------------------------------------------------------;;
(defun sum-and-groupby_qty (lst num / count countdata elem match tmp)
  
(while lst
  
(setq tmp (car lst))

(setq match (vl-remove-if-not '(lambda(x)(eq (nth num x)(nth num tmp) ))

					  lst))

(setq count (apply '+ (mapcar 'atoi (mapcar 'last  match))))
  
(setq elem (subst (itoa count) (last tmp)  tmp))
  
(setq countdata (cons elem countdata))

(setq lst (vl-remove-if '(lambda(x)(eq (nth num x)(nth num tmp) ))

					  lst))
  )
(vl-sort countdata '(lambda(a b)(< (nth num a)(nth num b))))
  
  )
;;---------------------------------------------------------------------;;
(defun get-table-content (tbl / col cols data datum row rows start tmp)

  (setq	cols  (vla-get-columns tbl)
	rows  (vla-get-rows tbl)
	start rows
	)
  (if (eq :vlax-true (vla-get-titlesuppressed tbl))
    (setq rows (1- rows))
  )
  (if (eq :vlax-true (vla-get-headersuppressed tbl))
    (setq rows (1- rows))
  )
  (setq row (- start rows))
  (repeat rows
    (setq col 0)
    (repeat cols
      (setq datum (vla-gettext tbl row col))
      (setq tmp (cons datum tmp))
      (setq col (1+ col))
    )
    (setq data (cons (reverse tmp) data))
    (setq tmp  nil)
    (setq row  (1+ row))
    )

  (reverse data)
)
;;----------------------------   main part   --------------------------------;;


(defun C:GRPT  (/ cnt col cols data ent idx n num row rows tabledata tbl tmp)
  
(setq ent (entsel "\nSelect table :"))

(setq idx (getint "\nEnter a column number :"))

(setq idx (1- idx))

(setq tbl (vlax-ename->vla-object (car ent)))
  
 (setq tabledata (cddr (get-table-content tbl)))

(setq rows (vla-get-rows tbl))

(setq cols (vla-get-columns tbl))

(setq row 2)

(vla-put-regeneratetablesuppressed tbl :vlax-true)

(setq tabledata (sum-and-groupby_qty tabledata idx))

(setq n 0)

(setq data nil)

(foreach x  tabledata

  (setq x (append (list (itoa (+ n 1))) (cdr x)))

  (setq data (cons x data))

  (setq n (1+ n))
  )

(setq data (reverse data))

(setq row 2)

  (setq num (length data))
  
(setq cnt (+ rows num))
  
(repeat num

  (setq tmp (car data))
  
(vla-InsertRowsAndInherit tbl row (- row 1) 1)

  (setq col 0)

  (while (< col cols)

    (vla-settext tbl row col (nth col tmp))

    (setq col (1+ col))
    )
  (setq row (1+ row))

  (setq data (cdr data))
  )
   
  (setq rows (vla-get-rows tbl))
  
  (vla-deleterows tbl (+ num 2)(- rows num))
  
(vla-put-regeneratetablesuppressed tbl :vlax-false)

(princ)
  
  )

(prompt "\n\t---\tStart command with GRPT\t---\n")
(prin1)
 (or (vl-load-com))
(princ)
~'o'~


Огромное спасибо!
А можно ещё чуток усложнить, добавив в колонке цифры со значением типа "1000 x 500" и т.п. их по аналогии свисти в группы, а количество считать...
Во вложении пример
Вложения
Тип файла: dwg
DWG 2007		 Пример-2.dwg (787.7 Кб, 1707 просмотров)
Positron вне форума  
 
Непрочитано 21.04.2012, 17:53
#9
Олег (jr.)

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

Попробуй заменить основную комманду:
Код:
[Выделить все] 
;;------------------------------------------------------------------;;
(defun sum-and-groupby_qty (lst num / count countdata elem match tmp)
  
(while lst
  
(setq tmp (car lst))

(setq match (vl-remove-if-not '(lambda(x)(equal x tmp 0.001) )

					  lst))
(setq count (apply '+ (mapcar 'atoi (mapcar 'last  match))))
  
(setq elem (subst (itoa count) (last tmp)  tmp))
  
(setq countdata (cons elem countdata))

  (setq lst (vl-remove-if '(lambda(x)(equal  x tmp 0.001) )

					  lst))
  )
(vl-sort countdata '(lambda(a b)(< (nth 0 a)(nth 0 b))))
  
  )
;;---------------------------------------------------------------------;;
(defun get-table-content (tbl / col cols data datum row rows start tmp)

  (setq	cols  (vla-get-columns tbl)
	rows  (vla-get-rows tbl)
	start rows
	)
;;;  (if (eq :vlax-true (vla-get-titlesuppressed tbl))
;;;    (setq rows (1- rows))
;;;  )
;;;  (if (eq :vlax-true (vla-get-headersuppressed tbl))
;;;    (setq rows (1- rows))
;;;  )
  (setq row (- start rows))
  (repeat rows
    (setq col 0)
    (repeat cols
      (setq datum (vla-gettext tbl row col))
      (setq tmp (cons datum tmp))
      (setq col (1+ col))
    )
    (setq data (cons (reverse tmp) data))
    (setq tmp  nil)
    (setq row  (1+ row))
    )

  (reverse data)
)
;;----------------------------   main part   --------------------------------;;


(defun C:GRPT  (/   cnt col cols ent idx num row rows tabledata tbl tmp)
  
(setq ent (entsel "\nSelect table :"))

  (initget 6)
  
(setq idx (getint "\nEnter a column number <1>:"))

  (cond ((not idx)(setq idx 1)))

(setq idx (1- idx))

(setq tbl (vlax-ename->vla-object (car ent)))
  
 (setq tabledata (get-table-content tbl))

(setq rows (vla-get-rows tbl))

(setq cols (vla-get-columns tbl))

(setq cnt rows)

(vla-put-regeneratetablesuppressed tbl :vlax-true)

(setq tabledata (sum-and-groupby_qty tabledata idx))

(setq row 0)

(setq num (length tabledata))
  
  (vla-InsertRowsAndInherit tbl 0 0 num)
(repeat num

  (setq tmp (car tabledata))

  (setq col 0)

  (while (< col cols)

    (vla-settext tbl row col (nth col tmp))

    (setq col (1+ col))
    )
  (setq row (1+ row))

  (setq tabledata (cdr tabledata))
  )
   
  (setq rows (vla-get-rows tbl))
  
  (vla-deleterows tbl num cnt)

(vla-put-regeneratetablesuppressed tbl :vlax-false)

(princ)
  
  )

(prompt "\n\t---\tStart command with GRPT\t---\n")
(prin1)
 (or (vl-load-com))
(princ)
~'o'~
Последний раз редактировалось Олег (jr.), 22.04.2012 в 10:20.
Олег (jr.) вне форума  
 
Автор темы   Непрочитано 21.04.2012, 19:42
#10
Positron


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

- выбрал таблицу
- 1 Enter по умолчанию 1 стоит,
- результат:

Command: GRPT
Select table :
Enter a column number <1>:
; error: no function definition: GET-TABLE-CONTENT

м... мож чо не так делаю?
Positron вне форума  
 
Непрочитано 21.04.2012, 20:43
1 | #11
Олег (jr.)

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

Цитата:
Сообщение от Positron Посмотреть сообщение
м... мож чо не так делаю?
Я же сказал - замени только основную команду GRPT,
остальные субрутины оставь как есть
Что непонятно?
Олег (jr.) вне форума  
 
Автор темы   Непрочитано 21.04.2012, 21:54
#12
Positron


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

Цитата:
Сообщение от Олег (jr.) Посмотреть сообщение
Я же сказал - замени только основную команду GRPT,
остальные субрутины оставь как есть
Что непонятно?
Сори, упустил... работает ток не все пощитало, вот пример до и после.
Вложения
Тип файла: dwg
DWG 2007		 Пример-3.dwg (657.9 Кб, 1709 просмотров)
Positron вне форума  
 
Непрочитано 21.04.2012, 23:12
#13
Олег (jr.)

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

Цитата:
Сообщение от Positron Посмотреть сообщение
Сори, упустил... работает ток не все пощитало, вот пример до и после.
Смотри код в посте #9
(У тебя изменяются условия в таблице, поэтому сделал для рисунка Пример-3.dwg,
если опять будешь чего менять, тогда переделывай сам)

~'o'~
Последний раз редактировалось Олег (jr.), 22.04.2012 в 10:24.
Олег (jr.) вне форума  
 
Непрочитано 28.06.2012, 08:21
#14
ashas-


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

Здраствуйте, прошу прощения, если задаю вопрос не в той теме. Но мои поиски наиболее подходящей потерпели фиаско .
Вопрос. Где находится информация о том какие ячейки(столбцы) в таблице объединины, и как достать эту информацию с помощью автолиспа?
ashas- вне форума  
 
Непрочитано 28.06.2012, 10:28
1 | #15
Олег (jr.)

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

Смотри функцию:
Код:
[Выделить все] 
(vla-IsMergedCell tableobj row col 'minRow 'maxRow 'minCol 'maxCol)
не забудь про одиночные кавычки

~'o'~
Последний раз редактировалось Олег (jr.), 28.06.2012 в 11:12.
Олег (jr.) вне форума  
 
Непрочитано 28.06.2012, 10:37
1 | #16
Дима_

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

Цитата:
Сообщение от Олег (jr.) Посмотреть сообщение
не забудь про одиночные кавычки
только они нужны у последних 4 аргументов (у row и col - не надо).
__________________
Когда в руках молоток все вокруг кажется гвоздями.
Дима_ вне форума  
 
Непрочитано 28.06.2012, 10:50
#17
ashas-


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

Олег (jr.), Дима_. Благодарю .
ashas- вне форума  
 
Автор темы   Непрочитано 03.05.2013, 18:06
#18
Positron


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

удалил дабы оформить луче и не отвекать других плохо оформленым вопросом, сильно извеняюсь
Последний раз редактировалось Positron, 03.05.2013 в 18:34.
Positron вне форума  
 
Непрочитано 03.05.2013, 18:22
#19
Олег (jr.)

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

Извини даже смотреть не буду,
не показал что должно получиться в результате
или ты думаешь остальные будут это делать за тебя?
Олег (jr.) вне форума  
 
Автор темы   Непрочитано 03.05.2013, 18:26
#20
Positron


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

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

P.S. Подскажите пожалуйста еще по поводу подачи вопроса, как лучше его оформлять кратко дабы не перегружать вопрос или описывать по каждому шагу чтоб было подробней?
Вложения
Тип файла: dwg
DWG 2007		 Пример-6.dwg (227.2 Кб, 1430 просмотров)
Последний раз редактировалось Positron, 03.05.2013 в 19:32.
Positron вне форума  
 
Непрочитано 04.05.2013, 00:06
#21
Олег (jr.)

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

Попробую завтра что-нибудь придумать,
сегодня занят был другими делами

Каждая возьня с таблицами сугубо индивидуальная,
поэтому трудно написать общую функцию, я сделал проще
выделяй нужный диапазон рамкой напимер А4:Е14 для данной таблицы
и удаляй ненужные строки
Пробуй
Код:
[Выделить все] 
(defun C:SUMT (/ colmax colmin celltxt col data interes en getcell marks maxcell mincell osm pmax pmin
	         rowmax rowmin row same sset sumlst tblobj tcnt temp tmp txtline )
  
  (vl-load-com)
;; local defun
;; based on code written by Lee Ambrosius
;; date: 3/24/04
;; edited 11/21/10
(defun getcell(tblobj pt / col lwrleft pick row uprright vector vheight  vwidth)
 
 (setq vheight (getvar "viewsize"))
 (setq vwidth (* (/ (nth 0 (getvar "screensize")) (nth 1 (getvar "screensize"))) vheight))

 (setq lwrleft (list (- (nth 0 (getvar "viewctr")) (/ vwidth 2)) (- (nth 1 (getvar "viewctr")) (/ vheight 2)) 0))
 (setq uprright (list (+ (nth 0 (getvar "viewctr")) (/ vwidth 2)) (+ (nth 1 (getvar "viewctr")) (/ vheight 2)) 0))

 (setq vector (vlax-make-safearray vlax-vbdouble '(0 . 2)))
 (vlax-safearray-fill vector '(1 1 1))
 (setq vector (vlax-make-variant vector))

 (setq pick (vlax-3d-point pt))

 (if pick 
   (if (= (vla-hittest tblobj pick vector 'row 'col) :vlax-true)
           (list row col)))
  (list row col)
  )

;; 				main part				;;

(princ "\n Выбор bctuj рабочего диапазона значений >> ")
  (setq osm (getvar 'osmode))
  (setvar 'osmode 0)
 (setq pmin (getpoint "\n\t  >>  Указать левую верхнюю ячейку диапазона таблицы >>" )
	pmax (getcorner pmin "\n\t  >>  Указать правую нижнюю ячейку диапазона таблицы >>" ))
    (setq sset (ssget "_C" pmin pmax '((0 . "ACAD_TABLE"))))
  (setq tblobj (vlax-ename->vla-object (ssname sset 0)))
;;;(setq pmin (getpoint "\n\t >> Specify the left (or top left) cell of the table range >>")
;;;      pmax (getcorner pmin "\n\t >> Specify the right (or bottom right) cell of the table range >>"))
  (setq mincell(getcell tblobj pmin))
  (setq maxcell(getcell tblobj pmax))
  (setq rowmin (car mincell)colmin (cadr mincell)
	rowmax (car maxcell)colmax (cadr maxcell)
	)

;; get contents of selected cell range: 
(setq data nil)
(setq row rowmin)
(while (<= row rowmax)
  (setq col 0)
  (setq txtline nil)
  (while (<= col colmax)
    (setq celltxt (vla-gettext tblobj row col))
    (setq txtline (cons celltxt txtline))
    (setq col (1+ col))
  ) ;_ end of while
  (setq data (append data (list (reverse txtline))))
  (setq row (1+ row))
) ;_ end of while
(setq data (reverse data))
(setq sumlst nil)
(while (setq tmp (car data))
  (setq interes (reverse (cdr (reverse (cdr (reverse tmp))))))
  (setq	same (vl-remove-if-not
	       '(lambda	(x)
		  (equal interes
			 (reverse (cdr (reverse (cdr (reverse x)))))
			 0.001
		  ) ;_ end of equal
		) ;_ end of lambda
	       data
	     ) ;_ end of vl-remove-if-not
  ) ;_ end of setq
  (if same
    (setq sumlst (if (= (length same) 1)
		   (cons (car same) sumlst)
		   (progn
		     (setq marks (apply	'strcat
					(mapcar	'(lambda (x)
						   (strcat x ",")
						 ) ;_ end of lambda
						(vl-sort (mapcar 'car same)
							 '(lambda (a b) (< a b))
						) ;_ end of vl-sort
					) ;_ end of mapcar
				 ) ;_ end of apply
			   marks (substr marks 1 (1- (strlen marks)))
		     ) ;_ end of setq
		     (setq temp (subst marks (caar same) (car same)))
		     (setq tcnt
			    (itoa
			      (apply '+ (mapcar 'atoi (mapcar 'last same)))
			    ) ;_ end of itoa
		     ) ;_ end of setq
		     (setq temp	(append	(reverse (cdr (reverse temp)))
					(list tcnt)
				) ;_ end of append
		     ) ;_ end of setq
		     (cons temp sumlst)
		   ) ;_ end of progn
		 ) ;_ end of if
    ) ;_ end of setq
  ) ;_ end of if
  (setq	data (vl-remove-if
	       '(lambda	(x)
		  (equal interes
			 (reverse (cdr (reverse (cdr (reverse x)))))
			 0.001
		  ) ;_ end of equal
		) ;_ end of lambda
	       data
	     ) ;_ end of vl-remove-if
  ) ;_ end of setq
) ;_ end of while
(setq sumlst (vl-sort sumlst '(lambda (a b) (< (car a) (car b)))))
(vlax-put-property
  tblobj
  'regeneratetablesuppressed
  :vlax-true
) ;_ end of vlax-put-property
(vla-deleterows tblobj rowmin (- rowmax rowmin))

(setq row (1+ rowmin))
(foreach item sumlst
  (vla-insertrowsandinherit tblobj row rowmin 1)
  (setq col 0)
  (foreach txt item
    (vla-settext tblobj row col txt)
    (setq col (1+ col))
  ) ;_ end of foreach
  (setq row (1+ row))
) ;_ end of foreach
(vla-deleterows tblobj rowmin 1)
(vlax-put-property
  tblobj
  'regeneratetablesuppressed
  :vlax-false
) ;_ end of vlax-put-property

 (setvar 'osmode osm)
  (princ)
  )
(prompt "\n\t\t---\tСтартуй командой:  SUMT \t---")
(prin1)
(or (vl-load-com)(princ))
Последний раз редактировалось Олег (jr.), 04.05.2013 в 09:22. Причина: добавлен код
Олег (jr.) вне форума  
 
Автор темы   Непрочитано 05.05.2013, 01:21
#22
Positron


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

Цитата:
Сообщение от Олег (jr.) Посмотреть сообщение
Попробую завтра что-нибудь придумать,
сегодня занят был другими делами

Каждая возьня с таблицами сугубо индивидуальная,
поэтому трудно написать общую функцию, я сделал проще
выделяй нужный диапазон рамкой напимер А4:Е14 для данной таблицы
и удаляй ненужные строки
Пробуй
Код:
[Выделить все] 
(defun C:SUMT (/ colmax colmin celltxt col data interes en getcell marks maxcell mincell osm pmax pmin
	         rowmax rowmin row same sset sumlst tblobj tcnt temp tmp txtline )
  
  (vl-load-com)
;; local defun
;; based on code written by Lee Ambrosius
;; date: 3/24/04
;; edited 11/21/10
(defun getcell(tblobj pt / col lwrleft pick row uprright vector vheight  vwidth)
 
 (setq vheight (getvar "viewsize"))
 (setq vwidth (* (/ (nth 0 (getvar "screensize")) (nth 1 (getvar "screensize"))) vheight))

 (setq lwrleft (list (- (nth 0 (getvar "viewctr")) (/ vwidth 2)) (- (nth 1 (getvar "viewctr")) (/ vheight 2)) 0))
 (setq uprright (list (+ (nth 0 (getvar "viewctr")) (/ vwidth 2)) (+ (nth 1 (getvar "viewctr")) (/ vheight 2)) 0))

 (setq vector (vlax-make-safearray vlax-vbdouble '(0 . 2)))
 (vlax-safearray-fill vector '(1 1 1))
 (setq vector (vlax-make-variant vector))

 (setq pick (vlax-3d-point pt))

 (if pick 
   (if (= (vla-hittest tblobj pick vector 'row 'col) :vlax-true)
           (list row col)))
  (list row col)
  )

;; 				main part				;;

(princ "\n Выбор bctuj рабочего диапазона значений >> ")
  (setq osm (getvar 'osmode))
  (setvar 'osmode 0)
 (setq pmin (getpoint "\n\t  >>  Указать левую верхнюю ячейку диапазона таблицы >>" )
	pmax (getcorner pmin "\n\t  >>  Указать правую нижнюю ячейку диапазона таблицы >>" ))
    (setq sset (ssget "_C" pmin pmax '((0 . "ACAD_TABLE"))))
  (setq tblobj (vlax-ename->vla-object (ssname sset 0)))
;;;(setq pmin (getpoint "\n\t >> Specify the left (or top left) cell of the table range >>")
;;;      pmax (getcorner pmin "\n\t >> Specify the right (or bottom right) cell of the table range >>"))
  (setq mincell(getcell tblobj pmin))
  (setq maxcell(getcell tblobj pmax))
  (setq rowmin (car mincell)colmin (cadr mincell)
	rowmax (car maxcell)colmax (cadr maxcell)
	)

;; get contents of selected cell range: 
(setq data nil)
(setq row rowmin)
(while (<= row rowmax)
  (setq col 0)
  (setq txtline nil)
  (while (<= col colmax)
    (setq celltxt (vla-gettext tblobj row col))
    (setq txtline (cons celltxt txtline))
    (setq col (1+ col))
  ) ;_ end of while
  (setq data (append data (list (reverse txtline))))
  (setq row (1+ row))
) ;_ end of while
(setq data (reverse data))
(setq sumlst nil)
(while (setq tmp (car data))
  (setq interes (reverse (cdr (reverse (cdr (reverse tmp))))))
  (setq	same (vl-remove-if-not
	       '(lambda	(x)
		  (equal interes
			 (reverse (cdr (reverse (cdr (reverse x)))))
			 0.001
		  ) ;_ end of equal
		) ;_ end of lambda
	       data
	     ) ;_ end of vl-remove-if-not
  ) ;_ end of setq
  (if same
    (setq sumlst (if (= (length same) 1)
		   (cons (car same) sumlst)
		   (progn
		     (setq marks (apply	'strcat
					(mapcar	'(lambda (x)
						   (strcat x ",")
						 ) ;_ end of lambda
						(vl-sort (mapcar 'car same)
							 '(lambda (a b) (< a b))
						) ;_ end of vl-sort
					) ;_ end of mapcar
				 ) ;_ end of apply
			   marks (substr marks 1 (1- (strlen marks)))
		     ) ;_ end of setq
		     (setq temp (subst marks (caar same) (car same)))
		     (setq tcnt
			    (itoa
			      (apply '+ (mapcar 'atoi (mapcar 'last same)))
			    ) ;_ end of itoa
		     ) ;_ end of setq
		     (setq temp	(append	(reverse (cdr (reverse temp)))
					(list tcnt)
				) ;_ end of append
		     ) ;_ end of setq
		     (cons temp sumlst)
		   ) ;_ end of progn
		 ) ;_ end of if
    ) ;_ end of setq
  ) ;_ end of if
  (setq	data (vl-remove-if
	       '(lambda	(x)
		  (equal interes
			 (reverse (cdr (reverse (cdr (reverse x)))))
			 0.001
		  ) ;_ end of equal
		) ;_ end of lambda
	       data
	     ) ;_ end of vl-remove-if
  ) ;_ end of setq
) ;_ end of while
(setq sumlst (vl-sort sumlst '(lambda (a b) (< (car a) (car b)))))
(vlax-put-property
  tblobj
  'regeneratetablesuppressed
  :vlax-true
) ;_ end of vlax-put-property
(vla-deleterows tblobj rowmin (- rowmax rowmin))

(setq row (1+ rowmin))
(foreach item sumlst
  (vla-insertrowsandinherit tblobj row rowmin 1)
  (setq col 0)
  (foreach txt item
    (vla-settext tblobj row col txt)
    (setq col (1+ col))
  ) ;_ end of foreach
  (setq row (1+ row))
) ;_ end of foreach
(vla-deleterows tblobj rowmin 1)
(vlax-put-property
  tblobj
  'regeneratetablesuppressed
  :vlax-false
) ;_ end of vlax-put-property

 (setvar 'osmode osm)
  (princ)
  )
(prompt "\n\t\t---\tСтартуй командой:  SUMT \t---")
(prin1)
(or (vl-load-com)(princ))
Огромное спасибо! На порядок меньше рутинной работы стало
Во вложении файлик с пробой команды, работает отлично!
Если можно, еще добавить сортировку по возрастанию для 2го типа колонки, в файле оформил в ручную описание с готовым примером.
Вложения
Тип файла: dwg
DWG 2007		 Пример-7.dwg (131.9 Кб, 650 просмотров)
Последний раз редактировалось Positron, 05.05.2013 в 01:36.
Positron вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Групирование строк в таблице



Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Сортировка строк в таблице автокада Crane AutoCAD 4 02.02.2010 02:12
Размер текста в таблице, связанной с файлом Excel TheMouther AutoCAD 2 09.12.2009 08:19
Как удалять в таблице линии внутри столбцов или внутри строк? Elbrus AutoCAD 8 03.11.2009 10:59
Можно ли править количество строк в таблице? XYZ AutoCAD 5 05.05.2009 21:19

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