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

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

вставка таблицы из MS Excell

Ответ
Поиск в этой теме
Непрочитано 18.06.2012, 20:46
вставка таблицы из MS Excell
baaba
 
архитектор
 
Москва
Регистрация: 07.07.2007
Сообщений: 644

Лично мне удобнее работать с таблицами в табличном процессоре, например Excel, Calc и прочее и только потом вставлять таблицу в чертёж. Может быть я плохо искал, но я не смог подобрать готового решения для вставки таблиц в чертёж из существующих программ для AutoCAD, в общем доступе и до сего момента вставлял таблицы через 'paste special', что имеет свои недостатки. В частности меня не устраивало то что нужно всякий раз подгонять таблицу по ширине и высоте, поправлять артефакты, возникающие при вставки и прочее. Возникла идея написать маленький лисп для автоматизации этого процесса. Из существующих наработок мне больше всего подошла библиотека Елпанова Евгения, http://elpanov.com/index.php?id=42#01, позволяющая читать напрямую файлы *.xls. Я написал небольшую обёртку для этой функции, надеюсь это кому-нибудь пригодиться, кроме меня. В архиве исходники и скомпилированный *.fas, можно пользоваться и тем и тем.
Таблица вставляется текущим текстовым стилем, в текущем слое. Масштаб 1:1, т. е. в единицах листа.

Код:
[Выделить все]
 ;|
Программа для вставки таблиц, спецификаций из Excel
Особенность данной программы - считывание данных о высоте строки, шапки, высоте текста и прочего из первых четырёх строк конкретного листа файла excell (см. пример, e.xls). Это позволяет работать с данными в Excel, вставлять таблицы в точном соответствии со стандартами Таблица рисуется отрезками и примитивами dtext (mtxt в шапке таблицы)
по данным Excell в текущем слое, текущим текстовым стилем, из указанного файла, указанного пользователем (ввод с клавиатуры) листом от верхней правой точки таблицы. Excel при этом не обязательно должен быть установлен, можно использовать любой табличный процессор, который может сохранять файлы в формате xls
|;
;Функция преобразования списка с чётным количеством элементов в список точечных
;пар
;(ccons '(1 2 3 4 5 6))
(defun ccons (lstin)
	(if (not (= lstin nil))
		(cons (cons (car lstin) (cadr lstin)) (ccons (cddr lstin)))
	)
)

;Текущий стиль
;(getvar "TEXTSTYLE")

;Функция рисования однострочного текста по точке, высоте текста, типу привязки
;и значению текстовой строки
;(drawtxt (getpoint) 3 "br" 3.5 wrnd)
;(drawtxt (getpoint) 3 "center" (nth 2 (nth 4 mlst)))
(defun drawtxt (pt th just txtstr wrnd)
	
	;(setq txtstr (nth 2 (nth 4 mlst)))
	;проверка, не является ли ввод реальным числом или пустым значением
	(cond
		((= (type txtstr) 'REAL) (setq txtstr (rtos txtstr 2 wrnd)))
		((= txtstr nil)			(setq txtstr ""))
	)

	(setq just
		(cond
			((= just "left")	(list 72 0 73 0))
			((= just "center")	(list 72 1 73 0))
			((= just "right")	(list 72 2 73 0))
			((= just "tl")		(list 72 0 73 3))
			((= just "tc")		(list 72 1 73 3))
			((= just "tr")		(list 72 2 73 3))
			((= just "ml")		(list 72 0 73 2))	
			((= just "mc")		(list 72 1 73 2))
			((= just "mr")		(list 72 2 73 2))	
			((= just "bl")		(list 72 0 73 1))
			((= just "bc")		(list 72 1 73 1))
			((= just "br")		(list 72 2 73 1))
		)
	)

	(entmake (append (ccons (list
			0 "TEXT"
			100 "AcDbEntity"
			100 "AcDbText"
			1 txtstr
			40 th
			51 (cdr (assoc 50 (tblsearch "STYLE" (getvar 'textstyle))))
			10 pt
			11 pt
			7 (getvar "TEXTSTYLE")
			)) (ccons just)))
)

;рисование многострочного текста по точке, высоте, типу привязки, ширине
;текстового блока и содержанию текста, ниже следует пример вызова
;(mkmtxt (getpoint) 3 "mc" 0.45 12 "teststring value")
;(mkmtxt (getpoint) 3 "mc" 0.45 12 (nth 2 (nth 4 mlst)))
(defun mkmtxt (pt th just row_space cellw txtstr / base)

	;(setq txtstr (nth 2 (nth 4 mlst)))
	;проверка, не является ли ввод реальным числом или пустым значением
	(cond
		((= (type txtstr) 'REAL) (setq txtstr (rtos txtstr)))
		((= txtstr nil)			(setq txtstr ""))
	)

	(setq base (list
			0 "MTEXT" 100 "AcDbEntity" 100 "AcDbMText" 1 txtstr 40 th 10 pt 11 pt 		
			41 cellw 44 row_space 50 0.0 7 (getvar 'textstyle) 
		))

	(setq just
		(cond
			((= just "tl") '(71 1))
			((= just "tc") '(71 2))
			((= just "tr") '(71 3))
			((= just "ml") '(71 4))	
			((= just "mc") '(71 5))
			((= just "mr") '(71 6))	
			((= just "bl") '(71 7))
			((= just "bc") '(71 8))
			((= just "br") '(71 9))
		)
	)

	(entmake (ccons (append base just)))
)

; Функция возвращает точку с приращением по X от исходной точки
(defun ofstx (pt ofstd)
	(list (+ ofstd (car pt)) (cadr pt))
)

; Функция возвращает точку с приращением по Y от исходной точки вниз 
(defun ofsty (pt ofstd)
	(list (car pt) (- (cadr pt) ofstd))
)

; Формирование списка координат вершин линий вертикальных разделителей таблицы
(defun mkptxlist (pt pts)
	(if pts (cons (setq pt (ofstx pt (car pts))) (mkptxlist pt (cdr pts))))
)
	
; Формирует список координат вершин линий горизонтальных разделителей таблицы
(defun mkptylist (pt ofstd rows)
	(if (>= rows 0)
		(cons pt (mkptylist (ofsty pt ofstd) ofstd (1- rows)))
	)
)

; Функция рисует линии по списку вершин с заданным углом и длиной
(defun draw_line (pts ang lh)
	(mapcar '(lambda (x) (command "_.line" x (polar x ang lh) "")) pts))



; Функция расставляет текст по спискам точек, привязок, значений текста,
; интервалов между вертикальными разделителями таблицы
;(drawtxtptstrlst ptlistx txth justlist (car (ccdr 3 mlst)) interlist wrnd)

;(defun drawtxtptstrlst (ptlistx txth justlst ptstrlst interlist)
;	(mapcar '(lambda (x y z n) (if (not (eq "" z))
;		(drawtxt (if (eq y "bc") (ofstx x (/ n 2)) (ofstx x 1.5)) txth y z)
;		)) ptlistx justlst ptstrlst interlist
;	)
;)

(defun drawtxtptstrlst (ptlistx txth justlst ptstrlst interlist wrnd)
	(mapcar '(lambda (x y z n) (if (not (eq "" z))
		(drawtxt
;			(if (eq y "bc") (ofstx x (/ n 2)) (ofstx x 1.5))
			(cond
				((eq y "bc") (ofstx x (/ n 2)))
				((eq y "br") (ofstx x (- n 1.5)))
				((eq y "bl") (ofstx x 1.5))
			)
			txth y z wrnd)
		)) ptlistx justlst ptstrlst interlist
	)
)

; Функция расставляет текст от исходного списка значений коодинат точек с приращением,
; по вертикали. Значения текстовых полей выбираются из прямоугольного массива
; значений (список списков) 
;(mdrtxt2 ptlistx txth justlist (cdr mlst) interlist theight wrnd)
(defun mdrtxt2 (ptlistx txth justlst str interlist theight wrnd)
	(while str
		(drawtxtptstrlst ptlistx txth justlst (car str) interlist wrnd)
		(setq ptlistx (mapcar '(lambda (x) (ofsty x theight)) ptlistx))
		(setq str (cdr str))
	)
)

; Пробная функция работы с прямоугольным массивом
;(mdrtxt (cdr (gtable)))
(defun mdrtxt (str / adata)
	(while str
		(setq adata (cons (car (car str)) adata))	
		(setq str (cdr str))
	)
	(reverse adata)
)

;Откусывает последний элемент списка
;Поискать готовые функции
(defun ucdr (lst)
	(reverse (cdr (reverse lst)))
)

;Убирает nil в списке
;(unil interlist)
(defun unil (lst)
	(if (eq (car (reverse lst)) nil) (unil (ucdr lst)) lst))
	


;Откусывает хвост начиная с элеметна N
;(setq a '(0 1 2 3 4 5))
;(ccdr 3 a)
(defun ccdr (n lst)
	(if (not (= 0 n)) (ccdr (1- n) (cdr lst)) lst))

;(draw_table (gtable))
(defun draw_table (mlst / justlst interlist theight txth frowh pt1 ptlistx ptlisty wrnd)

;Вычисление переменных разного рода
(setq
	justlist (nth 2 mlst)
	;justlst '("bc" "bl" "bc" "bc" "bc" "bc"); привязки текстовых полей в таблице	
	;interlist (mapcar 'atoi (nth 1 mlst))
	interlist (unil (nth 1 mlst))
	;interlist '(10.0 80.0 15.0 10.0); интервалы таблицы по гост
	theight (nth 1 (nth 0 mlst))
	;theight 5; высота строки (8 мм согласно ГОСТ)
	;txth (atof (vl-string-subst "." "," (nth 2 (nth 0 mlst))))
	txth (nth 2 (nth 0 mlst))
	;txth 3.5; высота строки текста
	wrnd (atoi (rtos (nth 4 (nth 0 mlst)) 2 0))  ; округление до
	frowh (nth 0 (nth 0 mlst))
	;frowh 10; высота первой строки 15 мм согласно ГОСТ
	;row_space 0.9; межстрочный интервал, для многострочного текста
	row_space (nth 3 (nth 0 mlst))
	pt1 (getpoint "\nEnter start point: "); левая верхняя точка таблицы
	ptlistx (cons pt1 (mkptxlist pt1 interlist)); ряд точек для рисования вертикальных линий
	ptlisty (cons pt1 (mkptylist (ofsty pt1 frowh) theight (length (ccdr 4 mlst)))); ряд точек для рисования горизонтальных линий
)

;Рисование вертикальных разделителей таблицы
(draw_line ptlistx (/ pi -2)
	(eval (list '- (cadr (car ptlisty)) (cadr (last ptlisty)))))

;Рисование горизонтальных разделителей таблицы
(draw_line ptlisty 0 (eval (cons '+ interlist))) 

; Заполнение шапки таблицы
;(setq ptlistx2
;	(mapcar '(lambda (x y) (ofsty (ofstx x (/ y 2.0)) (/ frowh 2.0))) ptlistx interlist)
;)
;(mkmtxt (getpoint) 3 "mc" row_space 33 "teststring value")
(mapcar '(lambda (x y z) (mkmtxt
	(ofsty (ofstx x (/ y 2.0)) (/ frowh 2.0))
	txth "mc" row_space (- y 1.0) z))
	ptlistx interlist (nth 3 mlst)
)

; Заполнение таблицы
(mdrtxt2
	(mapcar '(lambda (x) (ofsty x (+ frowh theight))) (ucdr ptlistx))
	txth justlist (ccdr 4 mlst) interlist theight wrnd
)

(princ)
)

(defun c:drawtable ( / old_osnap shlst c_sheet )
;Необходимо догрузить
(vl-load-com)
;Загрузка функции чтения из Excell
;http://elpanov.com/index.php?id=42#01
(load "readxls")
;(load "readcsv")

;http://forum.dwg.ru/archive/index.php/t-31628.html
;Запомнить путь к открытому файлу?
;(if (eq fn nil)
;	(setq fn (getfiled "Select a spreadsheet file" "" "xls" 8))
;	(setq fn (getfiled "Select a spreadsheet file" (strcat (vl-filename-directory (findfile fn)) "\\") "xls" 8))
;)

;(if fn
;	(setq fn (getfiled "Select a spreadsheet file" (strcat (vl-filename-directory (findfile fn)) "\\") "xls" 8))
;	(setq fn (findfile (getfiled "Select a spreadsheet file" "" "xls" 8)))
;)

(setq fn (findfile (getfiled "Select a spreadsheet file" "" "xls" 8)))

;(eea-get_xl (getfiled "Select a spreadsheet file" "c:/work/lisp/test/" "xls" 8))

;(setq fn (getfiled "Select a spreadsheet file" "c:/work/lisp/test/" "xls" 8)) 
(setq
;	xlsdata (eea-get_xl fn)
;	shlst (mapcar '(lambda (x) (vl-string-subst "" "$" x)) (mapcar 'car xlsdata))
;	shlst (mapcar 'car xlsdata)
	c_sheet (getstring "\nEnter sheet name: ") 
)

(command "_.undo" "_begin"); Метка отмены группы комманд
(setq old_osnap (getvar "OSMODE")); Старая привязка
(setvar "OSMODE" 0); Сброс всех привязок

;(draw_table (gtable))
;(draw_table (eea-get_xl_sheet (getfiled "Select a spreadsheet file" "c:/work/lisp/test/" "xls" 8) "sp1"))
(draw_table (eea-get_xl_sheet fn c_sheet))

;Восстановление привязки
(setvar "OSMODE" old_osnap)

;Метка отмены группы комманд
(command "_.undo" "_end")
)
PS Хотелось бы реализовать запоминание места, от куда брал последний раз таблицу и выбор листа из списка, через DCL.

Вложения
Тип файла: zip drawtable.zip (15.6 Кб, 344 просмотров)

Просмотров: 16077
 
Автор темы   Непрочитано 19.06.2013, 17:17
#21
baaba

архитектор
 
Регистрация: 07.07.2007
Москва
Сообщений: 644
<phrase 1= Отправить сообщение для baaba с помощью Skype™


Да, офис 32 бита.
baaba вне форума  
 
Непрочитано 19.06.2013, 19:07
#22
hwd

C, C++, C#
 
Регистрация: 07.10.2009
С-Пб.
Сообщений: 2,762
Отправить сообщение для hwd с помощью Skype™


вот поэтому и не работает. Подробней я это разжёвывал здесь.
__________________
Надеюсь, ты не социальный овощ? Это определяется делами! :welcome:

Последний раз редактировалось hwd, 19.06.2013 в 20:29.
hwd вне форума  
 
Непрочитано 01.08.2013, 21:03
#23
Олег (jr.)

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


Цитата:
Сообщение от baaba Посмотреть сообщение
Да, офис 32 бита.
Попробуй, будет у тебя работать?
(Используется текущий стиль)
Код:
[Выделить все]
(defun C:RXT (/ *error* acsp  address adoc col column colwids i indexes numrows pt rd row sheetnum
	      tbl tblrow tmp txt txtheight txtstyle wid wids x xlapp xlbook xlbooks xldata xlpath
	      xlrange xlresult xlsheet xlsheets y)
  ;| 	fixo * 2013 	|;
  (vl-load-com)
  (defun *error* (msg)
    (if xlapp (progn(vl-catch-all-apply 'vlax-invoke-method (list xlapp 'quit))(gc)))
    (princ)
    )
(if  (and (setq xlpath	(getfiled "Select Excel File:" (getvar "dwgprefix") "XLS;XLSX" 4))
       (setq sheetnum	1 );<-- sheet number (could be used the sheet name instead, i.e. Sheet1, Лист1 etc.)
	(setq 	address (getstring "\nPut a range address (i.e. A4:D11): "))
	(setq 	txtheight (getreal "\nPut a text height for table (i.e. 3): "))
       )

    (progn
      (setq xlapp (vlax-get-or-create-object "excel.application"))
      (setq xlbooks (vlax-get-property xlapp 'workbooks)
		 xlbook (vlax-invoke-method
			 xlbooks
			 'open
			 xlpath)
		 xlsheets  (vlax-get-property xlbook 'sheets)
		 xlsheet   (vlax-get-property xlsheets 'item sheetnum))
                (vlax-invoke-method xlsheet 'activate)
		 (setq xlsheet   (vlax-get-property xlapp 'activesheet))

      
	   (if (= (vlax-get-property xlapp 'visible) :vlax-false)
	     (vlax-put-property xlapp 'visible :vlax-true))
      
	   (setq xlrange (vlax-get-property xlsheet 'range address))

      (setq xldata (vlax-safearray->list
		     (vlax-variant-value
		       (vlax-get-property xlrange 'value2)
		     ) 
		   ) 
      ) 
      (setq
	xlresult (mapcar '(lambda (x) (mapcar 'vlax-variant-value x))
		       xldata
	       ) 
      )
  
	    (vl-catch-all-apply 'vlax-invoke-method (list xlbook 'close :vlax-false))  
   (gc)
     (vl-catch-all-apply 'vlax-invoke-method (list xlapp 'quit)) 
  (foreach x  (list xlrange xlsheet xlsheets xlbook xlbooks xlapp  )
	     (vl-catch-all-apply 'vlax-release-object (list x)))
      (setq xlapp nil)
      (gc)
      (if (not xlresult)(alert "Bad for you"))
  (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object))
	acsp (vla-get-block (vla-get-activelayout adoc)))
  (setq txtstyle (getvar "textstyle"))

(setq pt	(getpoint "\nSelect Point to Insert a Table: ")
  wid (* txtheight  10))

(setq wids
(mapcar '(lambda(x)(mapcar '(lambda(y)(strlen y)) x)) (mapcar '(lambda(x)(mapcar 'vl-princ-to-string x)) xlresult)))
(while (setq tmp (caar wids))
  (setq column (mapcar 'car wids))
  (setq colwids (append colwids (list (apply 'max column))))
  (setq wids (mapcar 'cdr wids)))
  (setq numrows (length xlresult))
(setq	tbl (vla-addTable acsp (vlax-3d-point pt)  3 (length (car xlresult)) (* txtheight 3.333) wid)
	row 2 i -1 indexes nil)
  (vla-put-vertcellmargin tbl (/ txtheight 5.))
  (vla-put-horzcellmargin tbl (/ txtheight 5.))
  (vla-setrowheight tbl 0 (* txtheight 3.333))(vla-setrowheight tbl 1 (* txtheight 3.333))
(and (mapcar '(lambda (x)(setq indexes(cons (setq i (1+ i)) indexes)))(car xlresult))
(setq indexes (reverse indexes)))
(setq row 2)
  (setq tblrow (car xlresult))
  
  (vla-SetCellStyle tbl row 0 "Data")
  
  (vla-setrowheight tbl row (* txtheight 3.333))
  (mapcar '(lambda (col txt)
	     (vla-SetText tbl row col (vl-princ-to-string txt))
	     (vla-SetCellTextStyle tbl row col txtstyle)
	     (vla-SetCellTextHeight tbl row col  txtheight)
	     (vla-setcellalignment tbl row col acMiddleCenter  )
	      ) indexes tblrow)
  (setq xlresult (cdr xlresult))
  (setq row (1+ row))
      
(while (setq tblrow (car xlresult))
   (vla-InsertRowsAndInherit tbl row (- row 1) 1)

   (mapcar '(lambda (col txt)
	      (vla-SetText tbl row col (vl-princ-to-string txt))
	      (vla-SetCellTextStyle tbl row col txtstyle)
	      (vla-SetCellTextHeight tbl row col  txtheight)
	      (vla-setcellalignment tbl row col acMiddleLeft  )
	      ) indexes tblrow)
  (setq xlresult (cdr xlresult)
	row (1+ row)) 
)

(foreach  index indexes
(vla-setcolumnwidth tbl index (* 0.8725 txtheight (nth index colwids))))
(vla-deleterows tbl 0 2)
  (mapcar '(lambda( rd )
	      (vla-settextheight tbl rd txtheight) )
	   (list acheaderrow acdatarow actitlerow)
	   )
(vla-put-height tbl (* numrows (* txtheight 2.66667)));<--- ГОСТ: 3.3333
  (vla-setrowheight tbl 0 (* txtheight 5))
  (vla-recomputetableblock tbl :vlax-true)
      )
  )
    (*error* nil)
  (princ)
  )
(prompt "\n\t=============================\n")
(prompt "\n\t	Введите RXT для старта ...   ")
(prompt "\n\t=============================\n")
(prin1)
(or (vl-load-com)(princ))
Олег (jr.) вне форума  
 
Непрочитано 11.03.2014, 19:47
#24
BoTTePa3


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


Я для работы писал похожую программу. Только без распознавания ориентации текста (вставляет "середина по центру", если размер текста превышает размер ячейки вставляет "многострочным"). Работает только с Excel с буквенным обозначением столбцов. В параметрах:
1. выбор текстового стиля
2. масштаб из пикселей Excel в единицы автокада (по ширине и высоте: "*" умножает, "/" делит)
3. возможность игнорирования ширины и высоты ячеек и ввода своих параметров
4. перевёртывает русские буквы в английские (если ошиблись с раскладкой)
5. возможность задавать размер текста в единицах автокада
Из недостатков:
1. Указание диапазона таблицы вводится вручную
2. Нет распознавания стиля и параметров шрифта в Excel
3. Нет распознавания объединённых ячеек
4. Работает только для столбцов в диапазоне "A" - "ZZ" (в противном случае будет ругаться)
5. Нет распознаёт стиль начертания контуров ячеек
6. Работает только с листом активным при сохранении
7. не допускает работы с открытым Excel
8. Собрана из кусков так что в коде - хаос
9. Точность до 8 знаков (можно исправить)
10. Толком не тестировалась
Ну ещё какие-то косяки 100% есть, просто сам редко ей пользуюсь и пока не расстраивала

оформлено через диалоговое окно, *.cuix прилагается. В *.fas не конвертировал
Вложения
Тип файла: rar EXCEL_BY_ACAD.rar (10.9 Кб, 85 просмотров)

Последний раз редактировалось BoTTePa3, 11.03.2014 в 19:50. Причина: не дописал параметры
BoTTePa3 вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Готовые программы > вставка таблицы из MS Excell

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

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Полезные таблицы для инженеров (самопальные и не только). Armin Поиск литературы, чертежей, моделей и прочих материалов 148 24.12.2022 12:46
LISP. Вставка в таблицу поля, соотвествующего площади примитива Profan Готовые программы 272 06.06.2021 23:12
как с помощью vba начертить линию vasyavip Программирование 77 09.10.2008 23:17
Вставка фрагментов таблицы из Excel в таблицу Автокада 2006 через буфер обмена - возможно ли? kp+ AutoCAD 3 21.03.2008 10:32
vb6 вставка таблицы AutoCad'a в таблицу Word'a HiddenM Программирование 1 11.01.2007 16:11