Добрый день! Скажите пожалуйста, возможно ли к данному коду
VVA пишет:> iv
Измененный вариант. Данные добавляются в текущую книгу в новый лист. Если текущей книги нет, она создается. Лист именуется "Имя_файла&Имя ф-ции (вариант)"
Напpимер:
Drawing1&SML
Drawing1&SML (1)
;|================== XLS ========================================
* Опубликовано [url=https://www.caduser.ru/forum/topic31444.html]https://www.caduser.ru/forum/topic31444.html[/url]
[url=https://www.caduser.ru/forum/topic31669.html]https://www.caduser.ru/forum/topic31669.html[/url]
* Назначение: Печать списка данных punto_datos в Excell
* Для вывода создается новая книга
Вывод осуществляется в первом листе
* Аргументы:
punto_datos - список списков данных (LIST) вида
((Value1 Value2 ... VlalueN)(Value1 Value2 ... VlalueN)...)
Каждый список вида (Value1 Value2 ... VlalueN) записывается
в отдельную строку в соответствующие столбцы (Value1-A Value2-B и .т.д.)
header - список (LIST) заголовков или nil вида ("Подпись A" "Подпись B" ...)
Если header nil, принимается ("X" "Y" "Z")
Colhide - список буквенных названий стоблцов для скрытия или nil - не скрывать
("A" "C" "D") - скрыть столбцы A, C, D
Name_list - имя нового листа активной книги или nil - новая книга
* Возврат: nil
* TIPS!!! : При передачи функции xls числовых вещественных данных нет необходимости проверять текущий системный
разделитель целой и дробной части ("HKEY_CURRENT_USER\\Control Panel\\International" "sDecimal")
Функцией на время вывода отключается использование в Excele системного разделителя, разделителем
целой и дробной части устанавливается точка. После завершения ф-ции все восстанавливается.
Пример вызова
(xls '((1.1 1.2 1.3 1.4)(2.1 2.2 2.3 2.4)(3.1 3.2 3.3 3.4)) '("Столбец1" "Столбец2" "Столбец3" "Столбец4") '("B"))|;
(vl-load-com)
(defun xls ( punto_datos header Colhide Name_list / *aplexcel* *books-colection* Currsep
*excell-cells* *new-book* *sheet#1* *sheet-collection* col iz_listo row cell cols)
(defun Letter (N / Res TMP)(setq Res "")(while (> N 0)(setq TMP (rem N 26)
TMP (if (zerop TMP)(setq N (1- N) TMP 26) TMP)
Res (strcat (chr (+ 64 TMP)) Res) N (/ N 26))) Res)
(if (null Name_list)(setq Name_list ""))
(setq *AplExcel* (vlax-get-or-create-object "Excel.Application"))
(if (setq *New-Book* (vlax-get-property *AplExcel* "ActiveWorkbook"))
(setq *Books-Colection* (vlax-get-property *AplExcel* "Workbooks")
*Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
*Sheet#1* (vlax-invoke-method *Sheet-Collection* "Add"))
(setq *Books-Colection* (vlax-get-property *AplExcel* "Workbooks")
*New-Book* (vlax-invoke-method *Books-Colection* "Add")
*Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
*Sheet#1* (vlax-get-property *Sheet-Collection* "Item" 1)))
(setq *excell-cells* (vlax-get-property *Sheet#1* "Cells"))
(setq Name_list (strcat (vl-filename-base(getvar "DWGNAME")) "&" Name_list) col 0 cols nil)
(vlax-for sh *Sheet-Collection* (setq cols (cons (strcase(vlax-get-property sh 'Name)) cols)))
(setq row Name_list)
(while (member (strcase row) cols)
(setq row (strcat Name_list " (" (itoa(setq col (1+ col)))")")))
(setq Name_list row)
(vlax-put-property *Sheet#1* 'Name Name_list)
(setq Currsep (vlax-get-property *AplExcel* "UseSystemSeparators"))
(vlax-put-property *AplExcel* "UseSystemSeparators" :vlax-false) ;_не использовать системные установки
(vlax-put-property *AplExcel* "DecimalSeparator" ".") ;_разделитель дробной и целой части
(vlax-put-property *AplExcel* "ThousandsSeparator" " ") ;_разделитель тысячей
(vla-put-visible *AplExcel* :vlax-true)(setq row 1 col 1)
(if (null header)(setq header '("X" "Y" "Z")))
(repeat (length header)(vlax-put-property *excell-cells* "Item" row col
(vl-princ-to-string (nth (1- col) header)))(setq col (1+ col)))(setq row 2 col 1)
(repeat (length punto_datos)(setq iz_listo (car punto_datos))(repeat (length iz_listo)
(vlax-put-property *excell-cells* "Item" row col (vl-princ-to-string (car iz_listo)))
(setq iz_listo (cdr iz_listo) col (1+ col)))(setq punto_datos (cdr punto_datos))(setq col 1 row (1+ row)))
(setq col (1+(length header)) row (1+ row))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
(strcat "A1:" (letter col)(itoa row))))) ;_ end of setq
(setq cols (vlax-get-property cell 'Columns))
(vlax-invoke-method cols 'Autofit)
(vlax-release-object cols)(vlax-release-object cell)
(foreach item ColHide (if (numberp item)(setq item (letter item)))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
(strcat item "1:" item "1"))))
(setq cols (vlax-get-property cell 'Columns))
(vlax-put-property cols 'hidden 1)
(vlax-release-object cols)(vlax-release-object cell))
(vlax-put-property *AplExcel* "UseSystemSeparators" Currsep)
(mapcar 'vlax-release-object (list *excell-cells* *Sheet#1* *Sheet-Collection* *New-Book* *Books-Colection*
*AplExcel*))(setq *AplExcel* nil)(gc)(gc)(princ))
(DEFUN mip-put-hyperlink ( ENAME URLDescription )
(if (eq (type ENAME) 'ENAME)(setq ENAME (vlax-ename->vla-object ENAME)))
(vlax-for hyp (vla-get-hyperlinks ENAME)(vla-delete hyp))
(vla-add (vla-get-hyperlinks ENAME) "about:blank" URLDescription))
(defun getnote (item / ent res dict)
(if (and (setq ent (vlax-vla-object->ename item))(cdr (assoc 360 (entget ent)))
(setq dict (member '(3 . "AEC_TEXT_NOTE")(entget (cdr (assoc 360 (entget ent)))))))
(setq res (cdr (assoc 1 (entget (cdr (assoc 360 (member '(3 . "AEC_TEXT_NOTE") dict)))))))
(setq res "")) res)
(defun setnote ( ent note_value / dict new_note edict lst aec_note xdic)
(setq xdic (vla-getextensiondictionary (vlax-ename->vla-object ent)))
(if (setq dict (cdr (assoc 360 (entget ent))))
(setq edict (entget dict)))
(setq lst (list
'(0 . "AEC_TEXT_NOTE")
'(102 . "{ACAD_REACTORS")
(cons 330 dict)
'(102 . "}")
(cons 330 dict)
'(100 . "AecDbObject")
'(102 . "{AEC_SUBOBJECT")
'(300 . "AecImpObj")
'(100 . "AecImpObj")
'(3 . "")
'(102 . "AEC_SUBOBJECT}")
'(102 . "{AEC_NULLOBJECT}")
'(100 . "AecDbTextNote")
(cons 1 note_value)))
(if (null(setq new_note (entmakex lst))) ;_Нет объекта AEC_TEXT_NOTE
(progn
(setq lst (list
'(0 . "XRECORD")
(cons 330 dict)
'(100 . "AcDbXrecord")
(cons 1 note_value)))
(setq new_note (entmakex lst))
)
)
(if new_note (progn
(if (setq aec_note(member '(3 . "AEC_TEXT_NOTE") edict))
(progn
(setq edict (vl-remove (car aec_note) edict))
(setq edict (vl-remove (cadr aec_note) edict))))
(setq edict (append edict (list (cons 3 "AEC_TEXT_NOTE")(cons 360 new_note))))
(entmod edict)
(if (null (assoc 360 (entget ent)))
(entmod (append (entget ent)(list(cons 360 dict))))))))
(defun Sum_Mline ( / SS ent vertex_list mline_length ret lay mline_tip)
(defun sum ( / found)(foreach item ret
(if (and (= (strcase(car item))(strcase lay))
(= (strcase(cadr item))(strcase mline_tip)))
(setq found item)))
(if found (setq ret (subst (list (nth 0 found)(nth 1 found)
(+ (last found) mline_length)) found ret))
(setq ret (append ret (list (list lay mline_tip mline_length))))))
(if (setq ss (ssget (list (cons 0 "MLINE"))))
(foreach item (vl-remove-if(function listp)(mapcar(function cadr)(ssnamex ss)))
(setq ent (entget item))
(setq vertex_list (mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= 11 (car x)))) ent)))
(if (= 2 (logand 2 (cdr(assoc 71 ent))))(setq vertex_list (append vertex_list (list (car vertex_list)))))
(setq mline_length (apply '+ (mapcar 'distance vertex_list (cdr vertex_list))))
(setq mline_tip (cdr(assoc 2 ent)))(setq lay (cdr(assoc 8 ent))) (sum)))
(setq ent ret ret nil)
(foreach item ent (if (assoc (car item) ret)
(setq ret (subst (append (assoc (car item) ret)(list(cdr item)))
(assoc (car item) ret) ret))
(setq ret (append ret (list(list (car item)(cdr item)))))))
(setq ret (vl-sort ret '(lambda(x y)(< (car x)(car y)))))
(setq ret (mapcar '(lambda(x)(list (car x)(vl-sort(cdr x) '(lambda(x y)(<(car x)(car y)))))) ret))
ret)
(defun Sum_Blk ( / SS ret lay bname bcount ent)
(defun sum ( / found)(foreach item ret
(if (and (= (strcase(car item))(strcase lay))(= (strcase(cadr item))(strcase bname)))(setq found item)))
(if found (setq ret (subst (list (nth 0 found)(nth 1 found)
(+ (last found) bcount)) found ret))
(setq ret (append ret (list (list lay bname bcount))))))
(if (setq ss (ssget (list (cons 0 "INSERT"))))
(foreach item (mapcar 'vlax-ename->vla-object(vl-remove-if(function listp)(mapcar(function cadr)(ssnamex ss))))
(setq lay (vla-get-layer item) bcount 1)
(setq bname (cond ((and (vlax-property-available-p item 'isdynamicblock)
(= (vla-get-isdynamicblock item) :vlax-true)) ;_ end of and
(vla-get-effectivename item))
(t (vla-get-name item))) ;_ end of cond
bname (strcat "'" bname)) (sum)))
(setq ent ret ret nil)
(foreach item ent (if (assoc (car item) ret)
(setq ret (subst (append (assoc (car item) ret)(list(cdr item)))
(assoc (car item) ret) ret))
(setq ret (append ret (list(list (car item)(cdr item)))))))
(setq ret (vl-sort ret '(lambda(x y)(< (car x)(car y)))))
(setq ret (mapcar '(lambda(x)(list (car x)(vl-sort(cdr x) '(lambda(x y)(<(car x)(car y)))))) ret))
ret)
;;;[url=http://dwg.ru/forum/viewtopic.php?t=8291&postdays=0&postorder=asc&start=30]http://dwg.ru/forum/viewtopic.php?t=8...c&start=30[/url]
(defun mip_MTEXT_Unformat ( Mtext / text Str )(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)
(defun add_note ( note_func / d obj ent adoc *error* undo lays Flag hyptxt sset Multiple str)
(defun *error* (msg)(princ msg)(vla-EndUndoMark adoc))
(vl-load-com)(setq adoc (vla-get-activedocument (vlax-get-acad-object))
lays (vla-get-layers adoc))(vla-StartUndoMark adoc)(setvar "CMDECHO" 0)
(setq d (getvar "UNDOCTL"))
(cond ((= d 0) (vl-cmdf "_.UNDO" "_All"))
((= d 3) (vl-cmdf "_.UNDO" "_Control" "_All"))
(t nil)) ;_ end of cond
(setq undo 0 Flag t Multiple nil str "\nОдин-> Выберите текст [" hyptxt "")
(while Flag (if Multiple (progn(princ "\nТекущее значение заметки <")(princ hyptxt)(princ ">\n")))
(initget "Undo Отмени Несколько Multiple Exit Выход оДин One _Undo Undo Multiple Multiple Exit Exit One One")
(setq d nil obj (entsel (strcat str (if (not (zerop undo)) "Отмени/" "")
(if Multiple "оДин/" "Несколько/") "Выход]" (if Multiple " <готово>: " " <выход>: "))))
(cond ((= obj "Undo")(if (not (zerop undo))(progn (setq hyptxt "")
(vl-cmdf "_UNDO" "_B")(setq undo (1- undo)))(alert "Нечего больше отменять")))
((= obj "Exit")(setq Flag nil d nil))((= obj "One")(setq hyptxt "" Multiple nil str "\nОдин-> Выберите текст ["))
((= obj "Multiple")(setq Multiple t hyptxt "" str "\nНесколько-> Выберите текст ["))
((null obj)(if Multiple (setq Flag t d t)(if (= (getvar "ERRNO") 52)(setq Flag nil)(princ " *** Мимо ***"))))
(t (setq ent (vlax-ename->vla-object (car obj)))
(cond ((= (vla-get-lock (vla-item lays (vla-get-layer ent))) :vlax-true)
(alert "На блокированном слое!"))
((wcmatch (strcase(vla-get-ObjectName ent)) "*TEXT")
(if Multiple (setq hyptxt (strcat hyptxt (VL-STRING-TRIM " " (mip_MTEXT_Unformat(vla-get-textstring ent))) " "))
(setq d t hyptxt (mip_MTEXT_Unformat(vla-get-textstring ent)))))
(t (alert "Объект не текст")))))(if d
(cond ((= (setq hyptxt (VL-STRING-TRIM " " hyptxt)) "")(princ "\n*Не введено значение заметки*"))
((setq sset (ssget "_:L"))(vl-cmdf "_UNDO" "_M")(setq undo (1+ undo))
(foreach item (vl-remove-if 'listp(mapcar 'cadr(ssnamex sset)))(eval (list note_func item hyptxt)))
(setq hyptxt "")) (t nil))));while
(vla-EndUndoMark adoc)(princ))
;|=============== Команда COOR ================================================
Экспорт координат указанных точек, выбранных объектов: точек, блоков, полилиний, сплайнов в текстовый файл, ексел.
Текстовый файл - либо txt, либо csv. Округление координат в соответствии с текущими настройками команды _UNITS|;
(defun c:COOR(/ cFile curPt filPath objSet oFlag oldMode ptLst sFlag lw isRus)
(defun group-by-num (lst num / ls ret)(if (= (rem (length lst) num ) 0)(progn (setq ls nil)
(repeat (/ (length lst) num)(repeat num (setq ls(cons (car lst) ls)lst (cdr lst)))
(setq ret (append ret (list (reverse ls))) ls nil)))) ret)
(defun PtCollect(SelSet)(mapcar 'cdr (mapcar '(lambda(x)(assoc 10 x))(mapcar 'entget
(vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))))); end of PtCollect
(defun PLCollect(SelSet / ret)
(foreach lw (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))
(cond ((wcmatch (vla-get-ObjectName lw) "*Polyline")
(setq ret (append ret (group-by-num (vlax-get lw 'Coordinates)
(if (=(vla-get-ObjectName lw) "AcDbPolyline") 2 3)))))
((=(vla-get-ObjectName lw) "AcDbSpline")(setq ret (append ret (group-by-num
(vlax-safearray->list(vlax-variant-value (vla-get-controlpoints lw))) 3))))
(t nil))) ret)
(vl-load-com)(setq isRus(= (getvar "SysCodePage") "ANSI_1251"))(if(not ptcol:mode)(setq ptcol:mode "Pick"))
(initget "Указать Точка Блоки Полилиния Pick pOints Blocks poLyline _Pick pOints Blocks poLyline Pick pOints Blocks poLyline")
(setq oldMode ptcol:mode ptcol:mode
(getkword (if IsRus (strcat "\nВыберите режим [Указать/Точка/Блоки/Полилиния или сплайн] <"
(cadr (assoc ptcol:mode '(("Pick" "Указать")("pOints" "Указать")("Blocks" "Блоки")("poLyline" "Полилиния")))) ">: ")
(strcat "\nSpecify mode [Pick/pOints/Blocks/poLyline or spline] <"ptcol:mode">: "))) ptLst nil)
(if(null ptcol:mode)(setq ptcol:mode oldMode))
(cond ((= "Pick" ptcol:mode)(setq curPt T)
(while curPt (setq curPt(getpoint (if IsRus
"\nУкажите точку или Enter завершения > " "\nPick point or Enter to continue > ")))
(if curPt (setq ptLst(append ptLst(list (trans curPt 1 0))))))); end condition #1
((= "pOints" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "POINT")))))(progn
(if IsRus (princ "\nВыберите точки и нажмите Enter ")(princ "\nSelect points and press Enter "))
(setq objSet(ssget '((0 . "POINT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #2
((= "Blocks" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "INSERT")))))(progn
(if IsRus(princ "\nВыберите блоки и нажмите Enter ")(princ "\nSelect blocks and press Enter "))
(setq objSet(ssget '((0 . "INSERT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #3
((= "poLyline" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "*POLYLINE,SPLINE")))))(progn
(if IsRus(princ "\nВыберите полилинии и нажмите Enter ")(princ "\nSelect polyline and press Enter "))
(setq objSet(ssget '((0 . "*POLYLINE,SPLINE"))))))(if objSet (setq ptLst(PLCollect objSet)))); end condition #4
); end cond
(if ptLst (progn (princ "\n+++++++ Coordinates list +++++++\n")(setq ptLst (mapcar '(lambda(x)(trans x 0 1)) ptLst))
(mapcar '(lambda(x)(princ(strcat "\n"(rtos(car x))","(rtos(cadr x))
(if(= 3(length x))(strcat ","(rtos(nth 2 x))) "")))) ptLst); end mapcar
(princ "\n\n+++++++++ End of list +++++++++")(initget "Файл Excel Не Text Excel Not _Text Excel Not Text Excel Not")
(setq sFlag (getkword (if IsRus "\nСохранить координаты в [Файл/Excel/Не сохранять] <Файл> : "
"\nSave coordinates to [Text file/Excel/Not save] <Text> : ")))
(if(null sFlag)(setq sFlag "Text"))
(cond ((and (= "Text" sFlag)(setq filPath
(getfiled (if IsRus "Сохранение координат в текстовый файл" "Save Coordinates to Text File") "Coordinates.txt" "txt;csv" 33)))
(setq cFile(open filPath "w"))(foreach ln ptLst (write-line (strcat (rtos(car ln))","(rtos(cadr ln))
(if(= 3(length ln))(strcat ","(rtos(nth 2 ln))))) cFile))(close cFile)(initget "Yes No")
(setq oFlag(getkword (if IsRus "\nОткрыть файл? [Yes/No] <No> : " "\nOpen text file? [Yes/No] <No> : " )))
(if(= oFlag "Yes")(startapp "notepad.exe" filPath))); end condition #1
((= "Excel" sFlag)(xls (mapcar '(lambda(x)(mapcar 'rtos x)) ptLst) nil nil "COOR")); end condition #2
(t nil)))) (princ)); end of c:COOR
;|=============== Команда HYP ================================================
Заносит введенное описание объекта всем выбранным примитивам как гиперссылку
Включенеи/отключение показа гиперссылок см. команды
_HYPERLINKOPTIONS (ГИПЕРСВОЙСТВА)|;
(defun C:HYP ( / sset hyptxt)(vl-load-com)
(setq hyptxt (getstring t "\nОписание объекта <выход>: "))
(setq hyptxt (VL-STRING-TRIM " " hyptxt))
(if (and (/= hyptxt "")(setq sset (ssget "_:L")))
(foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex sset))))
(mip-put-hyperlink item hyptxt)))(princ))
;|=============== Команда NOTE ================================================
Заносит введенное описание объекта всем выбранным примитивам как Notes|;
(defun C:NOTE ( / sset hyptxt)(vl-load-com)
(setq hyptxt (getstring t "\nОписание объекта <выход>: "))
(setq hyptxt (VL-STRING-TRIM " " hyptxt))
(if (and (/= hyptxt "")(setq sset (ssget "_:L")))
(foreach item (vl-remove-if 'listp (mapcar 'cadr (ssnamex sset)))
(setnote item hyptxt)))(princ))
;|=============== Команда AREAS ================================================
Выводит Слой, Описание, площадь,длинну, цвет, гиперссылку в соответствующие столбцы Excel.
Скрытие показа глобуса гиперссылки см. команды _HYPERLINKOPTIONS (ГИПЕРСВОЙСТВА)|;
(defun c:AREAS (/ selset file_name *error* retLst lst i UrlDes are Notes)
(defun *error* (msg)(princ msg)(princ)) ;_ end of defun
(vl-load-com)
(if (setq selset (ssget '((0 . "*POLYLINE"))))(progn (setq i 1)
(foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))
(setq Notes (getnote item) i (1+ i) UrlDes "")
(if(not (zerop(vla-get-Count (vla-get-Hyperlinks item))))
(VL-CATCH-ALL-APPLY '(lambda()(setq UrlDes(vla-get-URLDescription(vla-item (vla-get-Hyperlinks item) 0))))))
(setq lst (list
(strcat "'" (vla-get-layer item)) ;|Слой"|;
(if (= Notes "") "" (strcat "'" Notes)) ;|Notes полилинии|;
(rtos(setq are(vla-get-area item)) 2 12) ;|Площадь полилинии|;
(rtos(vla-get-Length item) 2 12) ;|Длина полилинии|;
(vla-get-color item) ;|Цвет полилинии|;
(if (= UrlDes "") "" (strcat "'" UrlDes)) ;|Гиперссылка|;
))
(setq retLst (append retLst (list lst))));_foreach
(xls retlst '("Слой" "Notes" "Площадь" "Длинна" "Цвет" "Гиперссылка") nil "AREAS")))
(princ))
;|=============== Команда T2N ================================================
Заносит значение текстовых объектов как Notes в вабранные объекты|;
(defun C:T2N ( )(add_note 'setnote))
;|=============== Команда T2HS ================================================
Заносит значение текстовых объектов как гиперссылку в вабранные объекты|;
(defun C:T2H ( )(add_note 'mip-put-hyperlink))
;;[url=https://www.caduser.ru/forum/topic19197.html]https://www.caduser.ru/forum/topic19197.html[/url]
;;Summ MLine
(defun c:SML (/ *error* retlst)
(defun *error* (msg)(princ msg)(princ)) ;_ end of defun
(vl-load-com)(setq retlst (Sum_Mline))
(setq retlst(mapcar '(lambda(x / lay)(setq lay (car x))
(mapcar '(lambda(y)(cons lay y))(cadr x))) retlst))
(if (setq retlst (apply 'append retlst))(xls retlst '("Слой" "ТИП" "Длина") nil "SML")
(princ "\n ** Нет мультилиний **"))(princ))
;;Summ Block
;;[url=https://www.caduser.ru/forum/topic31669.html]https://www.caduser.ru/forum/topic31669.html[/url]
(defun c:SBLK (/ *error* retlst)
(defun *error* (msg)(princ msg)(princ)) ;_ end of defun
(vl-load-com)(setq retlst (Sum_Blk))
(setq retlst(mapcar '(lambda(x / lay)
(setq lay (car x))
(mapcar '(lambda(y)(cons lay y))
(cadr x))) retlst))
(if (setq retlst (apply 'append retlst))
(xls retlst '("Слой" "Имя" "Количество") nil "SBLK")
(princ "\n ** Нет блоков **"))(princ))
(princ "\nНаберите в командной строке:")
(princ "\n\tSML - сумма мультилиний")
(princ "\n\tSBLK - сумма блоков")
(princ "\n\tT2H - текст в гиперссылку")
(princ "\n\tT2N - текст в Notes (ADT)")
(princ "\n\tAREAS - площади полилиний")
(princ "\n\tHYP - задать гиперссылку объектам")
(princ "\n\tNote - задать Notes объектам")
(princ "\n\tCOOR - экспорт координат")
Прилепить вот этот:
(if (car (atoms-family 1 '("vl-load-com"))) (vl-load-com))
(defun order_error (s)
(if txt (vla-delete txt))
(setq *error* old_error)
(setvar "CLAYER" old_sloy)
)
(defun mSpace (/ doc mSp)
(setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(if (= 1 (getvar "TILEMODE"))
(setq mSp (vla-get-ModelSpace doc))
(setq mSp (vla-get-PaperSpace doc)))
)
(defun oFind (/ selfnd n fTxt count lst lstmax)
(setq selfnd (ssget "X" (list (cons '8 '"order")(cons '0 '"TEXT"))) n 0 lstmax 0)
(if (/= selfnd nil)(setq count (sslength selfnd))(setq count 0))
(while (< n count)
(setq fTxt (vlax-ename->vla-object (ssname selfnd n)))
(setq lst (atoi(vla-get-textstring fTxt)) n (1+ n))
(if (< lstmax lst)(setq lstmax lst)))
(setq lstmax (1+ lstmax))
)
(defun oReplace (rTXT rNUM / sel)
(while (> (sslength (setq sel (ssget "X" (list (cons '8 '"order")(cons '0 '"TEXT")(cons '1 (itoa rNUM)))))) 1)
(progn
(setq sel (ssdel (vlax-vla-object->ename rTXT) sel))
(setq rTxt (vlax-ename->vla-object (ssname sel 0)))
(vla-put-textstring rTxt (itoa (setq rNum (1+ rNum))))))
)
(defun c:order (/ ht begin flg pick lt pt)
(setq ht 3 old_error *error* *error* order_error old_sloy (getvar "CLAYER") num (oFind))
(if (not (cdadr (tblsearch "LAYER" "order")))
(vla-add (vla-get-Layers (vla-get-ActiveDocument (vlax-get-Acad-Object))) "order"))
(setvar "CLAYER" "order")
(if (setq begin (getint (strcat "\nНачальный номер <" (itoa num) ">:")))(setq num begin))
(while (/= flg t)
(princ (strcat "\nУкажите местоположение номера [" (itoa num) "]:"))
(setq txt (vla-addtext (mSpace) (itoa num) (vlax-3d-point '(0 0 0)) ht))
(while (/= pick t)
(setq pt (cadr (setq lt (grread t))))
(if (and pt (listp pt))
(progn
(if (= (car lt) 5)(vla-put-insertionPoint txt (vlax-3d-point pt)))
(setq pick (= 3 (car lt))))
(progn (vla-delete txt)(setq flg t txt nil))))
(progn (oReplace txt num)(setq num (1+ num) pick nil)))
(setq *error* old_error)
(setvar "CLAYER" old_sloy)
)
Суть второго заключается в том что он проставляет номер в формате текста в указанной точке.
Можно ли соединить их и сделать доработанный аналог функции t2n, чтоб проставляемый текст сразу присваивался объекту в качестве текста?
