[AntSam]

есть таблица 1212.dwg
Можно ли с помощью лиспа посчитать сумму длин кабелей с разными сечениями и подсчитать одинаковые автоматы. Подскажите какие способы существуют для этого

[hwd]

Вас не настораживает наименование раздела ("Готовые программы")? Насколько я понимаю, здесь размещаются готовые решения. Вопросы задаются в др. ветке.

[Admin]

перемещено

[AntSam]

Извините за такой недочет!!!
И так на форуме имеется информация по поводу подсчета кабеля но она применима для блоков, а для таблицы можно как нибудь подправить этот код? просто я не знаком с Лиспом и надеюсь на вашу помощь

[Олег (jr.)]

Сообщение от AntSam есть таблица 1212.dwg Можно ли с помощью лиспа посчитать сумму длин кабелей с разными сечениями и подсчитать одинаковые автоматы. Подскажите какие способы существуют для этого

Возьми за основу

Код:

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

;;=========================GS.lsp=========================

(defun StripString (String / cstr1 cstr2 nString cnt1 tstr1)
; Strips out formation for color, font, height and width.
; written by T.Willey

(setq cnt1 1)
(while (and (setq cstr1 (substr String 1 1)) (> (strlen String) 0))
 (if (= cstr1 "\\")
  (progn
   (setq cstr2 (substr String 2 1))
   (if (member (strcase cstr2) '("C" "F" "H" "W" "T"));<-- added "T"
    (progn
     (while (/= (substr String cnt1 1) ";")
      (setq cnt1 (1+ cnt1))
     ); while
     (setq String (substr String (1+ cnt1) (strlen String)))
     (setq cnt1 1)
    ); progn
    (progn
     (if nString
      (setq nString (strcat nString (substr String 1 1)))
      (setq nString (substr String 1 1))
     ); if
     (setq String (substr String 2 (strlen String)))
    ); progn
   ); if
  ); progn
  (progn
   (if nString
    (setq nString (strcat nString (substr String 1 1)))
    (setq nString (substr String 1 1))
   ); if
   (setq String (substr String 2 (strlen String)))
  ); progn
 ); if
); while
  (if nString
(setq tstr1 (vl-string->list nString))(setq tstr1 '(34)));<-- added in case if empty string
(if (and tstr1(not (member 92 tstr1)) (member 123 tstr1))
 (setq tstr1 (vl-remove-if '(lambda (x) (or (= x 123) (= x 125))) tstr1))
); if
(vl-list->string tstr1)
)
;;local defun
(defun SumByFilter ( lst / first result)
  ; by Oleg Fateev aka fixo() 2010 * all rights reserved
  (while lst
      (setq first  (car lst))
         (setq result(cons  (cons (cadr first)
	(vl-princ-to-string	(apply '+ (mapcar 'atof(mapcar 'last 
               (vl-remove-if
		     (function (lambda (next)
				 (not (equal (cadr next)(cadr first)))
				 )
			       )
		     lst
		   )))
         ) 
      ))
	 result	
   )
 )
(setq lst (vl-remove-if
		     (function (lambda (next)
				 (equal (cadr next)(cadr first))
				 )
			       )
		     lst
		   )
   )
      )
  result
    )
;;=================================
(defun fillcell (tbl row col align wid  hmargin vmargin txtheight strtext)
  (if wid (vla-setcolumnwidth tbl  col wid))
	(vla-setcellalignment  tbl row col align )
	(vla-setcelltextheight  tbl row col txtheight )
	(vla-setmargin  tbl row col hmargin (* 1.5 txtheight ))
  (vla-setmargin  tbl row col vmargin (* 0.5 txtheight ))
	(vla-setText  tbl row col strtext)
  )
;;=================================

;; 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)
  (vl-load-com)
 (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 program
(defun C:GS(/ acsp adoc app atable celltext celltxt col colmax colmin cols data en headers
	    hgt i maxcell mincell osm pmax pmin pt1 row rowmax rowmin rows table_data tblobj tmp wids)
(vl-load-com)

(setq app (vlax-get-acad-object)
	adoc (vla-get-activedocument app)
	acsp (vla-get-modelspace adoc))
  (setq en (entsel "\n\t  >>  Выбрать таблицу >>"))
  
 (setq	tblobj (vlax-ename->vla-object (car en)))
  (setq osm (getvar 'osmode))
  (setvar 'osmode 0)
  (setq pmin (getpoint "\n\t  >>  Указать левую верхнюю ячейку диапазона таблицы >>" )
	pmax (getcorner pmin "\n\t  >>  Указать правую нижнюю ячейку диапазона таблицы >>" ))
  (setq mincell(GetCell tblobj pmin))
  (setq maxcell(GetCell tblobj pmax))
  (setq rowMin (car minCell)colMin (cadr MinCell)
	rowMax (car maxcell)colMax (cadr maxcell)
	)
  
 (vla-setsubselection tblobj rowMin rowMax colMin colMax)

  (vla-getsubselection tblobj 'rowMin 'rowMax 'colMin 'colMax)

  (setq row rowMin)
	(setq data nil)
  (while (<= row rowMax)
	(setq col colMin)
    (setq tmp nil)
  (while (<= col colMax)
    
    (setq celltxt (vla-gettext tblobj row col ))
    (setq tmp (if (eq "" celltext)(cons "" tmp)(cons (StripString celltxt) tmp)))
    (setq col (1+ col)))
    (setq data (append data (list (reverse tmp))))    
  (setq row (1+ row))
    )

  (vla-clearsubselection tblobj)
  (setq data (vl-remove-if '(lambda (x) (or (not (car x))(= (car x)  "\""))) data))
  (setq data (SumByFilter data))
  (setq data (mapcar  (function (lambda (x)(list (car x)(cdr x))))data))
(setq hgt 250.0)
    (setq headers (list "Марка"  "Длина, м." )
		     )
  (setq rows (length table_data)
	cols (length headers))
  (setq wids (list 2000 2000 ))
      ; pick a point for the table
      (setq pt1 (getpoint "\n\t>>  Указать точку вставки новой таблицы >>"))
      ; add the new table
      (setq atable (vla-AddTable 
                    acsp 
                    (vlax-3d-point pt1)
                    (+ 4 rows)
                   cols
                    500
                    1000))
   (vla-put-RegenerateTableSuppressed atable :vlax-true)
  (vla-settextstyle atable actitlerow "Standard")
  (vla-settextstyle atable acheaderrow "Standard")
  (vla-settextstyle atable acdatarow "Standard")
  (vla-put-TitleSuppressed atable :vlax-false)
  (vla-put-headerSuppressed atable :vlax-false)
  (vla-put-horzcellmargin atable (* hgt 0.4))
  (vla-put-vertcellmargin atable (* hgt 0.4))
  (vla-put-height atable(+ 700 (* rows 400.)));calculate table height
  (vla-put-width atable (apply'+ wids));calculate table width
  
  (setq i 0)
  (foreach wid wids    
    (vla-setcolumnwidth atable  i (nth i wids))
    (setq i (1+ i)))
  (fillcell atable 0 0 5 nil  0 1 (* hgt 1.5) "Выборка")
     (setq row 1 i 0)
      (vla-setrowheight atable row 700)
      (foreach item headers
	(vla-setrowheight atable row 400)
        (fillcell atable row i 5 nil  0 1 hgt (nth i headers ))

	  (setq i (1+ i)))

(setq row 2)
    (foreach line data
      (setq col 0)

      (foreach a line
       (fillcell atable row col 5 nil  0 1  hgt  (vl-princ-to-string a))
	(setq col (1+ col)))
      (setq row (1+ row))
      )
  
  (vla-put-RegenerateTableSuppressed atable :vlax-false)
  
  (vlax-release-object atable)
  
  (setvar 'osmode osm)
  (princ)
  )
(prompt "\n|t\t>>Команда для выполнения GS <<")
(prin1)
;;=================================

[AntSam]

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

[Олег (jr.)]

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

[AntSam]

я так и делал но получается через раз(

[Олег (jr.)]

Сообщение от AntSam я так и делал но получается через раз(

Первая ячейка должна быть "I5" (i5)
а вторая "L19"