Информационный портал для профессионалов в области САПР
Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Форумы CADUser → Программирование → LISP → Список площадей выделенных полилиний в тектовое окно (файл)
to VVA
Сорри, не разглядел, прочитал последнюю строчку... Думал о девченках :).
К сожалению МТЕКСТ не совсем подходит :(, не любят его у нас... Опять же всавляются данные, с разных слоев ...
Ну нет, так нет чего ругаться :)
;|================== XLS ========================================
* Опубликовано https://www.caduser.ru/forum/topic31444.html
https://www.caduser.ru/forum/topic31669.html
* Назначение: Печать списка данных 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
* Возврат: 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 / *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)
(setq *AplExcel* (vlax-get-or-create-object "Excel.Application")
*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)
*excell-cells* (vlax-get-property *Sheet#1* "Cells"))
(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)
;;;http://dwg.ru/forum/viewtopic.php?t=8291&postdays=0&postorder=asc&start=30
(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 Выход _Undo Undo Multiple Multiple Exit Exit")
(setq d nil obj (entsel (strcat str (if (not (zerop undo)) "Отмени/" "")
(if (null Multiple) "Несколько/" "") "Выход]"
(if Multiple " <готово>: " " <выход>: "))))
(cond ((= obj "Undo")(if (not (zerop undo))(progn (setq hyptxt "" Multiple nil str "\nОдин-> Выберите текст [")
(vl-cmdf "_UNDO" "_B")(setq undo (1- undo)))(alert "Нечего больше отменять")))
((= obj "Exit")(setq Flag nil d nil))
((= 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 (and d (/= (setq hyptxt (VL-STRING-TRIM " " hyptxt)) "")(princ "\nЗначение заметки <")(princ hyptxt)(princ ">")
(setq sset (ssget "_:L")))(progn (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 "" Multiple nil str "\nОдин-> Выберите текст ["))));while
(vla-EndUndoMark adoc)(princ))
;|=============== Команда 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)))
(princ))
;|=============== Команда T2N ================================================
Заносит значение текстовых объектов как Notes в вабранные объекты|;
(defun C:T2N ( )(add_note 'setnote))
;|=============== Команда T2HS ================================================
Заносит значение текстовых объектов как гиперссылку в вабранные объекты|;
(defun C:T2H ( )(add_note 'mip-put-hyperlink))
;;https://www.caduser.ru/forum/topic19197.html
;;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)
(princ "\n ** Нет мультилиний **"))(princ))
;;Summ Block
;;https://www.caduser.ru/forum/topic31669.html
(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)
(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 объектам")Добавлена SBLK. Для динамических блоков экспортируется эффектиывное имя. В T2N, T2H введена опция Несколько, добавлена очистка формата Mtext. Если используется не ADT, то Notes (T2N, Note) тоже записываются и экспортируются в Excel, правда чтобы их увидеть надо написать команду.
to VVA
Все как в сказке!
Как сделать что-бы команды T2N /н и T2H /н повторно срабатывали как /н? Но по умолчанию пусть остается /о!
В принципе получается готовый ГИС для простых задач. Прелесть его в простоте и в том, что он меняет данные когда просят а не автоматически! (В свое время намаялись с MAPinfo) и в реальной связи с офисом, потому что хоть убейся а отчеты с постоянно меняющимися формами можно сделать только в Excel :).
+ очень приемлемо считать объемы отделочных и "благоустроительных" работ!
Если я правильно понял, замни функцию add_note этой
(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))Ну все...
Можно сдавать в готовые программы :) Пусть люди наслаждаются!
Огромное человеческое спасибо VVA и kpblc!
Добавлена еще одна команда COOR - экспорт координат указанных точек, выбранных объектов: точек, блоков, полилиний, сплайнов в текстовый файл, ексел. Текстовый файл - либо txt, либо csv. Округление координат в соответствии с текущими настройками команды _UNITS
;|================== XLS ========================================
* Опубликовано https://www.caduser.ru/forum/topic31444.html
https://www.caduser.ru/forum/topic31669.html
* Назначение: Печать списка данных 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
* Возврат: 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 / *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)
(setq *AplExcel* (vlax-get-or-create-object "Excel.Application")
*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)
*excell-cells* (vlax-get-property *Sheet#1* "Cells"))
(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)
;;;http://dwg.ru/forum/viewtopic.php?t=8291&postdays=0&postorder=asc&start=30
(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)); 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)))
(princ))
;|=============== Команда T2N ================================================
Заносит значение текстовых объектов как Notes в вабранные объекты|;
(defun C:T2N ( )(add_note 'setnote))
;|=============== Команда T2HS ================================================
Заносит значение текстовых объектов как гиперссылку в вабранные объекты|;
(defun C:T2H ( )(add_note 'mip-put-hyperlink))
;;https://www.caduser.ru/forum/topic19197.html
;;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)
(princ "\n ** Нет мультилиний **"))(princ))
;;Summ Block
;;https://www.caduser.ru/forum/topic31669.html
(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)
(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 - экспорт координат")> VVA
Пользуюсь всем постоянно!
Очень удобно!
Выяснилось, что часто бывает нужно одновременно выводить разные параметры:
Поэтому приходится запускать поочередно SML SBLK AREAS! Т.к. на последнем объекте 7 этажей!:) Образуется до 20 файлов экселя! В результате некоторая путаница :).
Предлагаю попробовать сваять дополнительную функцию одновременно выносящую это добро на разные листы одной книги... Но ф-я нужна отдельная! Чтобы все указанные остались в первозданном виде...
Или попробовать, чтобы ИМЕЮЩИЕСЯ функции переносили данные, если открыта хоть одна книга Excel,(в последнюю открытую книгу если открыто несколько) на новый лист в этой книге. Листу присваивать имя - "имя файла dwg"&"имя функции" например "Этаж3вер4&SML".
Если второй вариант осуществим то он намного предпочтительнее и новая функция не нужна!
> iv
Измененный вариант. Данные добавляются в текущую книгу в новый лист. Если текущей книги нет, она создается. Лист именуется "Имя_файла&Имя ф-ции (вариант)"
Напpимер:
Drawing1&SML
Drawing1&SML (1)
;|================== XLS ========================================
* Опубликовано https://www.caduser.ru/forum/topic31444.html
https://www.caduser.ru/forum/topic31669.html
* Назначение: Печать списка данных 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)
;;;http://dwg.ru/forum/viewtopic.php?t=8291&postdays=0&postorder=asc&start=30
(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))
;;https://www.caduser.ru/forum/topic19197.html
;;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
;;https://www.caduser.ru/forum/topic31669.html
(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 - экспорт координат")> VVA
Да! Это оно!
Вешайтесь сметчики! Ежедневно изменяем строительные объемы! :) ;)
> VVA
Программы по прежнему СУПЕР! Применяются ежедневно многократно.
Однако стало нехватать полей в ф-и AREAS :)
Крайне нужны еще 2-3 изменяемых поля...
Конечно понимаю, что надо бы связать с Access вводить там, но ввод в связанные таблицы не понравился, кроме того придется кучу имеющихся данных перенабивать + тормоза...
Как я понял данные Notes хранятся в словаре, и можно создать новые...
По хорошему надо бы все изучить самому, но на это нужно время..., да и промокашка стала не та что в 23 :(. С налету читаешь и понимаешь, что нужно потратить не один вечер, а т.к. вечером тоже есть работа, сил на что-то новое почти нет.
А функций нужно ограниченное количество - 3-4 реестра... И в принципе больше пока не предвидится.
В общем просьба сделать ф-ю создающую этот самый словарь с тремя ТЕКСТОВЫМИ полями...
И 3 ф-и аналогичные t2n/t2h заполняющими эти поля. Либо ф-ю с параметром (именем поля в словаре)
И в Excel эти поля тоже нужны!
К сожалению своими силами в этом году я доэтого не дотащусь. А нужно прям счас! Долбаная регпалата запрашивает реестры с расширенными данными (которые на чертежах имеются)... Да и начальство тоже - то это ему то то...
Один раз конечно можно было бы и вбить в таблицу, но постоянно меняющиеся конфигурации и назначения помещений (всех 500! :))
а можно ли вствить значения етих площадей замкнутых поллилинии внутри обекта на чертеже?
> iv
Снабдил текст комантариями, должен разобраться, если нет - спрашивай
;;Записывает в словарь dict_name примитива ent данные dict_value
;; ent - имя примитива [Ename or Vla-Object]
;; dict_name - имя словаря [String]
;; dict_value - значение в словаре [String]
;;Usage (DICTADDTOENAMEBYNAME (car(entsel)) "ABRA-CADABRA" "This is my note" )
(defun DictAddToEnameByName ( ent dict_name dict_value / dict new_dict edict lst dict_note xdic)
(if (= (type ent) 'VLA-OBJECT)(setq ent (vlax-vla-object->ename ent)))
(setq xdic (vla-getextensiondictionary (vlax-ename->vla-object ent)))
(setq dict_name (strcase (vl-princ-to-string dict_name)))
(setq dict_value (vl-princ-to-string dict_value))
(if (setq dict (cdr (assoc 360 (entget ent))))
(setq edict (entget dict)))
(setq lst (list
'(0 . "XRECORD")
(cons 330 dict)
'(100 . "AcDbXrecord")
(cons 1 dict_value)))
(setq new_dict (entmakex lst))
(if new_dict (progn
(if (setq dict_note (member (cons 3 dict_name) edict))
(progn
(setq edict (vl-remove (car dict_note) edict))
(setq edict (vl-remove (cadr dict_note) edict))))
(setq edict (append edict (list (cons 3 dict_name)(cons 360 new_dict))))
(entmod edict)
(if (null (assoc 360 (entget ent)))
(entmod (append (entget ent)(list(cons 360 dict))))))))
;;Читает из словаря dict_name примитива ent данные
;; ent - имя примитива [Ename or Vla-Object]
;; dict_name - имя словаря [String]
;;Usage (DICTGETFROMENAMEBYNAME (car(entsel)) "ABRA-CADABRA")
(defun DictGetFromEnameByName ( ent dict_name / res dict)
(setq dict_name (strcase (vl-princ-to-string dict_name)))
(if (= (type ent) 'VLA-OBJECT)(setq ent (vlax-vla-object->ename ent)))
(if (and ent (cdr (assoc 360 (entget ent)))
(setq dict (member (cons 3 dict_name)(entget (cdr (assoc 360 (entget ent)))))))
(setq res (cdr (assoc 1 (entget (cdr (assoc 360 (member (cons 3 dict_name) dict)))))))
(setq res "")) res)
;;Клепай по образу и подобию свои ф-ции, меняя IV? на свое
(defun setnote_IV1 (ent note_value )(DictAddToEnameByName ent "IV1" note_value))
(defun setnote_IV2 (ent note_value )(DictAddToEnameByName ent "IV2" note_value))
(defun setnote_IV3 (ent note_value )(DictAddToEnameByName ent "IV3" note_value))
;;Клепай по образу и подобию свои команды T2N?? , меняя название команды и имя ф-ции
(defun C:T2N-IV1 ( )(add_note 'setnote_IV1))
(defun C:T2N-IV2 ( )(add_note 'setnote_IV2))
(defun C:T2N-IV3 ( )(add_note 'setnote_IV3))
(defun C:MYNOTE ( / sset hyptxt dict-name)(vl-load-com)
(initget "IV1 IV2 IV3")
(setq dict-name (strcase(getstring "Имя словаря [IV1/IV2/IV3] <IV1>: ")))
(if (= dict-name "")(setq dict-name "IV1"))
(setq hyptxt (getstring t (strcat "\nОписание объекта для " dict-name " <выход>: ")))
(setq hyptxt (VL-STRING-TRIM " " hyptxt))
(if (and (/= hyptxt "")(setq sset (ssget "_:L")))
(foreach item (vl-remove-if 'listp (mapcar 'cadr (ssnamex sset)))
(DictAddToEnameByName item dict-name hyptxt)))(princ))
(defun c:MYAREAS (/ 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)) ;|Гиперссылка|;
;;>>>> Добавляй строки по образу и подобию меняя IV? на имя своего словаря <<<<
(if (= (setq Notes (DictGetFromEnameByName item "IV1")) "") "" (strcat "'" Notes)) ;|Словарь IV1|;
(if (= (setq Notes (DictGetFromEnameByName item "IV2")) "") "" (strcat "'" Notes)) ;|Словарь IV2|;
(if (= (setq Notes (DictGetFromEnameByName item "IV3")) "") "" (strcat "'" Notes)) ;|Словарь IV3|;
))
(setq retLst (append retLst (list lst))));_foreach
;;>>> Добавляй в список свои поля <<<
(xls retlst '("Слой" "Notes" "Площадь" "Длинна" "Цвет" "Гиперссылка" "IV1" "IV2" "IV3") nil "AREAS")))
(princ))> VVA
Ес ичиз!!!
Как сделать чтобы функция T2Nxxx, выбирала только один объект, после чего сразу сразу вносила данные и переключалась на новый текст (без пробела/Enter)?
Но только ОДНА ИЗ НИХ, не все!
Это будет контроль уникальности вносимого значения:)
И возможно ли чтоб словарь сам не давал присваивать значение имеющееся у другого примитива кроме "" (пустого). Если делать сложно, особенно если будет обращаться к диску (некоторая задержка) то делать не нужно! Ставиться все должно быстро как сейчас!
И, кстати чем очистить словарь?? Подразумевается одно поле (напр IV1).
(defun add_note1 ( note_func / d obj ent adoc *error* undo lays Flag hyptxt sset)
(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)
(initget "Undo Отмени Exit Выход _Undo Undo Exit Exit")
(while Flag
(setq obj (entsel (strcat "\n Выберите текст ["
(if (not (zerop undo)) "Отмени/" "")
"Выход] <выход>: ")))
(cond ((= obj "Undo")(if (not (zerop undo))(progn
(vl-cmdf "_UNDO" "_B")(setq undo (1- undo)))(alert "Нечего больше отменять")))
((= obj "Exit")(setq Flag nil))
((null obj)(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")
(setq hyptxt (vla-get-textstring ent))(setq hyptxt (VL-STRING-TRIM " " hyptxt))
(if (and (/= hyptxt "")
(princ "\nЗначение заметки <")(princ hyptxt)(princ ">")
(setq sset (ssget "_:L")))(progn
(vl-cmdf "_UNDO" "_M")(setq undo (1+ undo))
(foreach item (vl-remove-if 'listp(mapcar 'cadr(ssnamex sset)))
(eval (list note_func item hyptxt)))
)))
(t (alert "Объект не текст")))))
(initget "Undo Отмени Exit Выход _Undo Undo Exit Exit"))
(vla-EndUndoMark adoc)(princ))
;;Клепай по образу и подобию свои команды T2N?? , меняя название команды и имя ф-ции
(defun C:T2N1-IV1 ( )(add_note1 'setnote_IV1))
(defun C:T2N1-IV2 ( )(add_note1 'setnote_IV2))
(defun C:T2N1-IV3 ( )(add_note1 'setnote_IV3))И, кстати чем очистить словарь?? Подразумевается одно поле (напр IV1).
Еще добавочка
(defun DictRemoveFromEnameByName ( ent dict_name / del )
(setq dict_name (strcase (vl-princ-to-string dict_name)))
(if (/= (type ent) 'VLA-OBJECT)(setq ent (vlax-ename->vla-object ent)))
(if (vlax-write-enabled-p ent)
(progn
(vlax-for dict (vla-getextensiondictionary ent)
(if (= dict_name (strcase (vla-get-Name dict)))(setq del dict))
)
(if (= (type del) 'VLA-OBJECT)
(if (vl-catch-all-error-p
(vl-catch-all-apply 'vla-delete (list del))
)
(alert (strcat "Не удалось удалить " dict_name))
)
)
)
(alert "\nСлой блокирован")
)
)
(defun str-str-lst (str pat / i)
(cond ((= str "") nil)
((setq i (vl-string-search pat str))
(cons (substr str 1 i)
(str-str-lst (substr str (+ (strlen pat) 1 i)) pat)) ;_ cons
)
(t (list str))) ;_ cond
) ;_ defun
(defun mydcl ( zagl info-list / fl ret dcl_id)(vl-load-com)
(if (null zagl)(setq zagl "Выбор"))
(setq fl (vl-filename-mktemp "mip" nil ".dcl"))
(setq ret (open fl "w"))
(mapcar '(lambda(x)(write-line x ret))
(list "mip_msg : dialog { " (strcat "label=\"" zagl "\";")
" :list_box {" "alignment=top ;" "width=51 ;"
(if (> (length info-list) 26) "height= 26 ;"
(strcat "height= " (itoa(+ 3 (length info-list))) ";"))
"is_tab_stop = false ;" "key = \"info\";}" "ok_cancel;}"))
(setq ret (close ret))
(if (setq dcl_id (load_dialog fl))
(if (new_dialog "mip_msg" dcl_id)(progn
(start_list "info")(mapcar 'add_list info-list)
(end_list)(set_tile "info" "0")(setq ret (car info-list))
(action_tile "info" "(setq ret (nth (atoi $value) info-list))")
(action_tile "cancel" "(progn(setq ret nil)(done_dialog 0))")
(action_tile "accept" "(done_dialog 1)")
(start_dialog))))(unload_dialog dcl_id) ret)
(defun C:-DELMYNOTE ( / sset dict-name)(vl-load-com)
(initget "IV1 IV2 IV3")
(setq dict-name (strcase(getstring "Имя словаря для удаления [IV1/IV2/IV3] <IV1>: ")))
(if (= dict-name "")(setq dict-name "IV1"))
(if (and (/= hyptxt "")(setq sset (ssget "_:L")))
(foreach item (vl-remove-if 'listp (mapcar 'cadr (ssnamex sset)))
(DictRemoveFromEnameByName item dict-name)))(princ))
(defun C:DELMYNOTE ( / ent dict-lst del)(vl-load-com)
(if (setq ent (car(entsel "\nВыберите объект для удаления записей")))
(if (and (setq ent (vlax-ename->vla-object ent))(vlax-write-enabled-p ent))
(progn
(vlax-for dict (vla-getextensiondictionary ent)
(setq dict-lst (append dict-lst (list
(strcat (vla-get-Name dict) " = "
(DictGetFromEnameByName ent (vla-get-Name dict))))))
)
(if dict-lst
(progn
(setq del (mydcl "Список словарей" dict-lst)
del (vl-string-trim " " (car(str-str-lst del "="))))
(DictRemoveFromEnameByName ent del)
)
(alert "Нет словарей")
)
)
(alert "\nСлой блокирован")
)
)
(princ)
)
(defun C:NOTE? ( / ent dict-lst)(vl-load-com)
(if (setq ent (car(entsel "\nВыберите объект для просмотра записей")))
(if (and (setq ent (vlax-ename->vla-object ent))(vlax-write-enabled-p ent))
(progn
(vlax-for dict (vla-getextensiondictionary ent)
(setq dict-lst (append dict-lst (list
(strcat (vla-get-Name dict) " = "
(DictGetFromEnameByName ent (vla-get-Name dict))))))
)
(mapcar '(lambda (x)(terpri)(princ x)) dict-lst)
(if dict-lst (mydcl "Список словарей" dict-lst)
(alert "Нет словарей"))
)
(alert "\nСлой блокирован")
)
)
)На всякий случай команды
-DELMYNOTE - удаление словаря выбраннЫХ объектов по имени ком строка
DELMYNOTE - удаление словаря выбраннОГО объекта по имени диалог
NOTE? - что за словари диалог
add_note1 похоже должна быть такой
(defun add_note1 ( note_func / d obj ent adoc *error* undo lays Flag hyptxt sset)
(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)
(initget "Undo Отмени Exit Выход _Undo Undo Exit Exit")
(while Flag
(setq obj (entsel (strcat "\n Выберите текст ["
(if (not (zerop undo)) "Отмени/" "")
"Выход] <выход>: ")))
(cond ((= obj "Undo")(if (not (zerop undo))(progn
(vl-cmdf "_UNDO" "_B")(setq undo (1- undo)))(alert "Нечего больше отменять")))
((= obj "Exit")(setq Flag nil))
((null obj)(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")
(setq hyptxt (vla-get-textstring ent))(setq hyptxt (VL-STRING-TRIM " " hyptxt))
(if (and (/= hyptxt "")
(princ "\nЗначение заметки <")(princ hyptxt)(princ ">")
(setq sset (ssget "_:S:L")))(progn
(vl-cmdf "_UNDO" "_M")(setq undo (1+ undo))
(foreach item (vl-remove-if 'listp(mapcar 'cadr(ssnamex sset)))
(eval (list note_func item hyptxt)))
)))
(t (alert "Объект не текст")))))
(initget "Undo Отмени Exit Выход _Undo Undo Exit Exit"))
(vla-EndUndoMark adoc)(princ))> VVA
Все работает и подходит идеально. Просто нет слов... :)
Спасибо!
> VVA
Что может значить:
Command: _-DELMYNOTE
Имя словаря для удаления : NomSekc
Select objects: 1 found
Select objects:
; error: ActiveX Server returned the error: unknown name: Name
выдают ф-и -DELMYNOTE, DELMYNOTE, NOTE? на одном чертеже, на остальных работают....
Purge и аудит не помогают...
Аудит правда пишет:
Pass 1 1400 objects audited; error: no function definition:
ZX:REAC-AR-LEN-ALL
Pass 1 13700 objects audited
Auditing Entities Pass 2
Pass 2 1400 objects audited; error: no function definition:
ZX:REAC-AR-LEN-ALL
Pass 2 13700 objects audited
Auditing Blocks
367 Blocks audited
Total errors found 0 fixed 0
Erased 0 objects
чего на тех чертежах где ф-и работают нет.
Установка и вывод в Excel на этом чертеже работают нормально.
> iv
Пришли мне по почте этот чертеж. Посмотрю
Исправленные ф-ции
;;--------------------------------
(defun DictRemoveFromEnameByName ( ent dict_name / del )
(setq dict_name (strcase (vl-princ-to-string dict_name)))
(if (/= (type ent) 'VLA-OBJECT)(setq ent (vlax-ename->vla-object ent)))
(if (vlax-write-enabled-p ent)
(progn
(vlax-for dict (vla-getextensiondictionary ent)
(if (= dict_name (cond
((vlax-property-available-p dict 'Name)
(strcase (vla-get-Name dict)))
((vlax-property-available-p dict 'ObjectName)
(strcase (vla-get-ObjectName dict)))
(t "")))(setq del dict))
)
(if (= (type del) 'VLA-OBJECT)
(if (vl-catch-all-error-p
(vl-catch-all-apply 'vla-delete (list del))
)
(alert (strcat "Не удалось удалить " dict_name))
)
)
)
(alert "\nСлой блокирован")
)
)
(defun str-str-lst (str pat / i)
(cond ((= str "") nil)
((setq i (vl-string-search pat str))
(cons (substr str 1 i)
(str-str-lst (substr str (+ (strlen pat) 1 i)) pat)) ;_ cons
)
(t (list str))) ;_ cond
) ;_ defun
(defun mydcl ( zagl info-list / fl ret dcl_id)(vl-load-com)
(if (null zagl)(setq zagl "Выбор"))
(setq fl (vl-filename-mktemp "mip" nil ".dcl"))
(setq ret (open fl "w"))
(mapcar '(lambda(x)(write-line x ret))
(list "mip_msg : dialog { " (strcat "label=\"" zagl "\";")
" :list_box {" "alignment=top ;" "width=51 ;"
(if (> (length info-list) 26) "height= 26 ;"
(strcat "height= " (itoa(+ 3 (length info-list))) ";"))
"is_tab_stop = false ;" "key = \"info\";}" "ok_cancel;}"))
(setq ret (close ret))
(if (setq dcl_id (load_dialog fl))
(if (new_dialog "mip_msg" dcl_id)(progn
(start_list "info")(mapcar 'add_list info-list)
(end_list)(set_tile "info" "0")(setq ret (car info-list))
(action_tile "info" "(setq ret (nth (atoi $value) info-list))")
(action_tile "cancel" "(progn(setq ret nil)(done_dialog 0))")
(action_tile "accept" "(done_dialog 1)")
(start_dialog))))(unload_dialog dcl_id) ret)
(defun C:-DELMYNOTE ( / sset dict-name)(vl-load-com)
(initget "NOMSEKC TYPESEKC PRIMSEKC AEC_TEXT_NOTe" )
(setq dict-name (strcase(getstring "Имя словаря для удаления [NOMSEKC/TYPESEKC/PRIMSEKC/AEC_TEXT_NOTE] <Nomsekc>: ")))
(if (= dict-name "")(setq dict-name "NomSekc"))
(if (and (/= hyptxt "")(setq sset (ssget "_:L")))
(foreach item (vl-remove-if 'listp (mapcar 'cadr (ssnamex sset)))
(setq II item)
(DictRemoveFromEnameByName item dict-name)))(princ))
(defun C:DELMYNOTE ( / ent dict-lst del name)(vl-load-com)
(if (setq ent (car(entsel "\nВыберите объект для удаления записей")))
(if (and (setq ent (vlax-ename->vla-object ent))(vlax-write-enabled-p ent))
(progn
(vlax-for dict (vla-getextensiondictionary ent)
(setq dict-lst (append dict-lst (list
(strcat (setq name (cond ((vlax-property-available-p dict 'Name)
(strcase (vla-get-Name dict)))
((vlax-property-available-p dict 'ObjectName)
(strcase (vla-get-ObjectName dict)))
(t ""))) " = "
(DictGetFromEnameByName ent name)))))
)
(if dict-lst
(progn
(setq del (mydcl "Список словарей" (acad_strlsort dict-lst))
del (vl-string-trim " " (car(str-str-lst del "="))))
(DictRemoveFromEnameByName ent del)
)
(alert "Нет словарей")
)
)
(alert "\nСлой блокирован")
)
)
(princ)
)
(defun C:NOTE? ( / ent dict-lst name)(vl-load-com)
(if (setq ent (car(entsel "\nВыберите объект для просмотра записей")))
(if (and (setq ent (vlax-ename->vla-object ent))(vlax-write-enabled-p ent))
(progn
(vlax-for dict (vla-getextensiondictionary ent)
(setq dict-lst (append dict-lst (list
(strcat (setq name (cond ((vlax-property-available-p dict 'Name)
(strcase (vla-get-Name dict)))
((vlax-property-available-p dict 'ObjectName)
(strcase (vla-get-ObjectName dict)))
(t ""))) " = "
(DictGetFromEnameByName ent name )))))
)
(mapcar '(lambda (x)(terpri)(princ x)) dict-lst)
(if dict-lst (mydcl "Список словарей" (acad_strlsort dict-lst))
(alert "Нет словарей"))
)
(alert "\nСлой блокирован")
)
)
)Обещанный добавочек
;;;Выбор объектов по значению данных в указанном словаре
;;;Маска выбора может включать шаблоны (см описание ф-ции wcmatch)
;;; Пример - есть 3 объекта, у которых есть словарь NOMSEKC со значениями
;;; - N11
;;; - N22
;;; - AN33
;;; Если в качестве маски указать N* , то выбирутся объекты со словарями N11 и N22
;;; Если в качестве маски указать *N* , то выбирутся объекты со словарями N11 , N22 и AN33
(defun C:-SELMYNOTE ( / sset dict-name sset1 mask str)(vl-load-com)
(initget "NOMSEKC TYPESEKC PRIMSEKC AEC_TEXT_NOTe" )
(setq dict-name (strcase(getstring "Имя словаря для выделения [NOMSEKC/TYPESEKC/PRIMSEKC/AEC_TEXT_NOTE] <Nomsekc>: ")))
(if (= dict-name "")(setq dict-name "NomSekc"))
(setq mask (getstring t "\nМаска поиска (типа Склад*): ")
mask (vl-string-trim " " (strcase mask))
)
(setq sset1 nil sset1 (ssadd))
(if (setq sset (ssget "_:L"))(progn
(foreach item (vl-remove-if 'listp (mapcar 'cadr (ssnamex sset)))
(if (and (/= (setq str (DictGetFromEnameByName item dict-name)) "")
(wcmatch (strcase str) mask))
(ssadd item sset1))
(if (> (sslength sset1) 0)(sssetfirst sset1 sset1)(sssetfirst nil nil)))))
(setq sset1 nil sset nil)(princ))> VVA
Выбор работает хорошо.
А как выбрать объекты в которых словарь не заполнен?
> iv
В нижеприведенной ф-ции в ответ на "Маска поиска" нажать ENTER
Исправленный вариант ф-ции
;;;Выбор объектов по значению данных в указанном словаре
;;;Маска выбора может включать шаблоны (см описание ф-ции wcmatch)
;;; Пример - есть 3 объекта, у которых есть словарь NOMSEKC со значениями
;;; - N11
;;; - N22
;;; - AN33
;;; Если в качестве маски указать N* , то выбирутся объекты со значениями N11 и N22
;;; Если в качестве маски указать *N* , то выбирутся объекты со значениями N11 , N22 и AN33
;;; Если в качестве маски указать ENTER , то выбирутся объекты со значениями "" (пробелы игнорируются)
(defun C:-SELMYNOTE ( / sset dict-name sset1 mask)(vl-load-com)
(initget "NOMSEKC TYPESEKC PRIMSEKC AEC_TEXT_NOTe" )
(setq dict-name (strcase(getstring "Имя словаря для выделения [NOMSEKC/TYPESEKC/PRIMSEKC/AEC_TEXT_NOTE] <Nomsekc>: ")))
(if (= dict-name "")(setq dict-name "NomSekc"))
(setq mask (getstring t "\nМаска поиска (типа Склад*) <пусто>: ")
mask (vl-string-trim " " (strcase mask))
)
(setq sset1 nil sset1 (ssadd))
(if (setq sset (ssget "_:L"))(progn
(foreach item (vl-remove-if 'listp (mapcar 'cadr (ssnamex sset)))
(if (and (cdr (assoc 360 (entget item)))
(member (cons 3 dict-name)(entget (cdr (assoc 360 (entget item)))))
(wcmatch (strcase (vl-string-trim " " (DictGetFromEnameByName item dict-name))) mask))
(ssadd item sset1))
(if (> (sslength sset1) 0)(sssetfirst sset1 sset1)(sssetfirst nil nil)))))
(setq sset1 nil sset nil)(princ))> VVA
Не находит вообще ничего... Ни при каких обстоятельствах... Ни с текстом, ни пустые.
Проходит так-же как первая, объекты выбирает, а на выходе - завершает работу и все...
Визуальное сравнение причину не выявило :).
Как вариант - данные поиска вводить не руками а вабирать из существующего dtext
(откуда теоретически они и были внесены).
Форумы CADUser → Программирование → LISP → Список площадей выделенных полилиний в тектовое окно (файл)
Форум работает на PunBB, при поддержке Informer Technologies, Inc
