Перейти к содержимому раздела
Форумы CADUser
Информационный портал для профессионалов в области САПР
Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Дерево сообщений Активные темы Темы без ответов
Настройки поиска (Страница 1 из 75)
Страницы 1 2 3 … 75 Далее
Темы от VVA Обычный поиск
Сообщений найдено с 1 по 25 из 1,859
Пример получения строки поля (опубликовано http://forum.dwg.ru/showthread.php?p=15 … st1544329)
(vl-load-com)
(defun C:DEMO6 ()
(setq en (car(nentsel "\nВыберите атрибут ")))
(princ "\nСтрока поля: ")
(princ(bg:FieldCode en))(princ)
)
(defun bg:FieldCode (ent / foo elst xdict dict field str)
;; credits gile gc:FieldCode
(defun ObjIdxStr (fld / pos)
(setq pos (vl-string-search "ObjIdx " (cdr (assoc 2 fldId)) 0))
(substr fld (1+ pos) (- (vl-string-search ">%" fld pos) pos))
)
(defun foo (field str / pos fldID objID)
(setq pos 0)
(if (setq pos (vl-string-search "\\_FldIdx " str pos))
(while (setq pos (vl-string-search "\\_FldIdx " str pos))
(setq fldId (entget (cdr (assoc 360 field)))
field (vl-remove (assoc 360 field) field))
(setq
str (strcat
(substr str 1 pos)
(if (setq objID (cdr (assoc 331 fldId)))
(vl-string-subst
;;; (strcat "ObjId " (itoa (gc:EnameToObjectId objID))) ;;; VVA 2015-12-07
(strcat "ObjId " (bg:GetObjectIDString objID))
;;; "ObjIdx" ;;; rem VVA 2015-12-07
(ObjIdxStr (cdr (assoc 2 fldId))) ;;; add VVA 2015-12-07
(cdr (assoc 2 fldId))
)
(foo fldId (cdr (assoc 2 fldId)))
)
(substr str (1+ (vl-string-search ">%" str pos)))
)
)
)
str
)
)
(setq elst (entget ent))
(if (vlax-property-available-p (vlax-ename->vla-object ent) 'Textstring)
(cond ((= (cdr(assoc 0 elst)) "MULTILEADER")
(setq str (cdr(assoc 304 elst)))
)
((and ;;; MTEXT ATTRIB ADD VVA 2011-20-27
(member (cdr(assoc 0 elst)) '("ATTRIB"))
(member '(101 . "Embedded Object") elst)
)
(setq str (apply 'strcat (append (bg:massoc 3 elst)(bg:massoc 1 (member '(101 . "Embedded Object") elst)))))
)
((member (cdr(assoc 0 elst)) '("TEXT" "MTEXT" "ATTRIB"))
(setq str (apply 'strcat (append (bg:massoc 3 elst)(bg:massoc 1 elst))))
)
(t (setq str (vla-get-TextString (vlax-ename->vla-object ent))))
)
)
(if (and
(member (cdr (assoc 0 elst)) '("ATTRIB" "MTEXT" "TEXT" "MULTILEADER"))
(setq xdict (cdr (assoc 360 elst)))
(setq dict (dictsearch xdict "ACAD_FIELD"))
(setq field (dictsearch (cdr (assoc -1 dict)) "TEXT"))
)
(setq str (foo field (cdr (assoc 2 field))))
)
str
)
(defun bg:GetObjectIDString ( obj / *util* )
(if (eq (type obj) 'ENAME)
(setq obj (vlax-ename->vla-object obj))
)
(setq *util* (vla-get-Utility (vla-get-ActiveDocument (vlax-get-acad-object))))
(if (vlax-method-applicable-p *util* 'GetObjectIdString)
(vla-GetObjectIdString *util* obj :vlax-false)
(itoa (vla-get-ObjectId obj))
)
)
(defun bg:massoc (key alist)(mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= key (car x)))) alist)))
Largo_GT пишет:при использовании "Вариант программы для корректной работы в 2016 Автокаде" тоже самое.
Поможите люди добрые.
Проверил этот вариант (http://forum.dwg.ru/showpost.php?p=1525 … stcount=14) на 2015 Автокаде.
Все работает. Возможно дело в файле
Вариант программы для корректной работы в 2016 Автокаде
AUTOCAD 2016 не работает программа вырезания фрагмента генплана Помогите внести изменения.
;|====================================================
Фрагмент чертежа по прямоуг.,кругл. или ломаной границе
(программа тестировалась на AutoCAD 2006-2012)
История программы:
https://www.caduser.ru/forum/topic44865.html
Для работы в 2016 Автокаде
http://forum.dwg.ru/showthread.php?p=1497028#post1497028
Программа Дениса Флюстикова "Fragm_Den" от 25.07.12:
Возможность получения результата без обработки блоков.
Макрос для кнопки:
^C^C^P(load "Fragm_Den");Fragm_Den
Замечания и предложения по адресу fd-@mail.ru
====================================================|;
(defun c:Fragm_Den (/ *error* aa1 aa2 aa3 aa4 aa5 aa6 aa7 aa8 aa9
aa10 aa11 aa12 aa13 aa14 aa15 aa16 aa17 aa18 aa19)
(if (>= (atof (getvar "ACADVER")) 16.2)(progn
(initget 128 "К Л")
(setq aa10 "Размер" ; Слой построения контура
aa15 1 ; 1- Расчленение блоков, 2- Через "_.xclip", 0- Блоки без
редактирования
aa18 1 ; 1- Результат примитивами, 0- Блоком
; При масштабировании результата:
aa11 1 ; 1- С сохранением масштаба штриховки, 0- Без
aa12 1 ; 1- С сохранением глоб.толщины полилиний, 0- Без
aa13 1 ; 1- С сохранением значения размеров, 0- Без
aa14 145 ; Цвет (1-255) отмасштабированных размеров, 0- Без изменения
aa8 (ssadd)
aa2 nil
aa5 nil
aa1 (getpoint "\nПервая точка прямоугольной области или [Круглая/Ломаная]
<Ломаная>:")
aa17 T
aa19 nil)
(if (> (+ aa11 aa12 aa13) 0)(setq aa19 (list aa11 aa12 aa13 aa14)))
(vl-load-com)
(cond
((= (type aa1) 'LIST)
(if (setq aa2 (getcorner aa1 "\nВторая точка области:"))(progn
(setq aa1 (trans aa1 1 0)
aa2 (trans aa2 1 0)
aa7 (list (cons 10 aa1)
(cons 10 (list (car aa1)(cadr aa2)))
(cons 10 aa2)
(cons 10 (list (car aa2)(cadr aa1))))
)
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")
)
))
((= aa1 "К")
(initget 1)
(setq aa1 (getpoint "\nЦентр круглой области:"))
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")
(if aa10 (if (tblsearch "Layer" aa10)(setvar "CLAYER" aa10)))
(princ "\nРадиус области:")
(vl-cmdf "_.circle" aa1)
(while (= (getvar 'cmdactive) 1)
(setq aa2 (vl-cmdf pause)))
(if aa2 (progn
(setq aa2 (cadr (grread 1 1))
aa2 (trans aa2 1 0)
aa4 (entlast)
aa3 (vlax-ename->vla-object aa4)
aa5 (vlax-curve-getEndParam aa3)
aa5 (vlax-curve-getDistAtParam aa3 aa5)
aa5 (/ aa5 256.0)
aa1 0
aa7 '())
(repeat 256
(setq aa7 (append aa7 (list (cons 10 (vlax-curve-getpointatdist aa3 aa1))))
aa1 (+ aa1 aa5))
)
)))
(T
(setq aa1 (getpoint "\nПервая точка ломаной границы или <Выбрать>:"))
(if aa1 (progn
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")
(princ "\nСледующая точка границы:")
(if (vl-cmdf "_.line" aa1 pause)(progn
(setq aa1 (list aa1))
(princ "\nСледующая точка границы или <Прервать>:")
(while (= (getvar 'cmdactive) 1)
(setq aa3 (getvar "lastpoint")
aa7 (car aa1)
aa6 aa1
aa1 (cons aa3 aa1)
aa8 (ssadd (entlast) aa8))
(if (equal (last aa1) aa3 1e-6)
(vl-cmdf "")(progn
(while (> (length aa6) 2)
(setq aa6 (cdr aa6))
(if (or (inters aa3 aa7 (car aa6)(cadr aa6) t)
(equal (angle aa3 aa7)(angle (caddr aa1) aa7) 1e-6)
(equal aa3 aa7 1e-6))(progn
(vl-cmdf "_u")
(princ "\nСамопересечение границы\nСледующая точка границы или <Прервать>:")
(setq aa1 (cdr aa1)
aa6 nil)))
)
(setq aa3 (vl-cmdf pause))
))
)
))
(if (and aa3 (> (length aa1) 2))
(setq aa2 (trans (getvar "lastpoint") 1 0)
aa7 '())(progn
(setq aa2 nil)
(command "_.undo" "_b")
))
(mapcar '(lambda (q) (setq aa7 (append aa7 (list (cons 10 (trans q 1 0)))))) aa1)
)(progn
(setq aa1 (entsel "\nВыберите полилинию или <Выход>:"))
(if aa1 (progn
(setq aa2 (trans (cadr aa1) 1 0)
aa4 (car aa1)
aa5 (entget aa4)
aa11 aa4
aa7 '())
(if (wcmatch (cdr (assoc 0 aa5)) "*POLYLINE")(progn
(if (= (cdr (assoc 0 aa5)) "POLYLINE")(while aa11
(setq aa11 (entnext aa11)
aa9 (entget aa11))
(if (= (cdr (assoc 0 aa9)) "VERTEX")
(setq aa7 (append aa7 (list (assoc 10 aa9)))
aa7 (append aa7 (list (assoc 42 aa9))))
)
(if (= (cdr (assoc 0 aa9)) "SEQEND")
(setq aa11 nil
aa5 aa7
aa7 '())
)))
(setq aa5 (append aa5 (list '(10)))
aa9 nil
aa11 (vlax-ename->vla-object aa4))
(mapcar '(lambda (q)
(if (= (car q) 10)(if aa9 (progn
(if (cdr q)
(setq aa12 (vlax-curve-getDistAtPoint aa11 (cdr q)))
(setq aa12 (vlax-curve-getDistAtParam aa11 (vlax-curve-getEndParam aa11)))
)
(if (null (setq aa13 (vlax-curve-getDistAtPoint aa11 (cdr (last aa7)))))
(setq aa13 0))
(setq aa9 (fix (abs (/ (atan aa9) pi 1e-3)))
aa12 (/ (- aa12 aa13) aa9))
(repeat aa9
(setq aa13 (+ aa13 aa12)
aa7 (append aa7 (list (cons 10 (vlax-curve-getPointAtDist aa11 aa13)))))
)
)(if (cdr q)(setq aa7 (append aa7 (list q)))))
(if (= (car q) 42)(if (= (setq aa9 (cdr q)) 0)(setq aa9 nil)
)))) aa5)
(if (< (length aa7) 3)(progn
(setq aa2 nil)
(princ "\nВыбранная полилиния имеет меньше трех вершин")
))
)
(progn
(setq aa2 nil)
(princ "\nВыбранный объект не является полилинией")
))
))
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")
)
)
)
)
(if aa2 (progn
(defun *error* (msg)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(if (< (atof (getvar "ACADVER")) 17.1)
(vla-sendcommand (vla-get-activedocument
(vlax-get-acad-object)) "_.undo 1 ")
(command nil nil nil nil "_.undo" 1))
(princ "\nВыход во время обработки данных\n")
)
(if aa10 (if (tblsearch "Layer" aa10)(setvar "CLAYER" aa10)))
(setq aa3 (list (cons 0 "LWPOLYLINE")(cons 100 "AcDbEntity")(cons 100 "AcDbPolyline"))
aa7 (append (list (cons 90 (length aa7))(cons 70 1)) aa7)
aa1 '())
(entmake (append aa3 aa7))
(setq aa16 (entlast))
(mapcar '(lambda (q)
(if (= (car q) 10)
(setq aa1 (cons (trans (cdr q) 0 1) aa1)))
) aa7)
(if aa5
(setq aa8 (ssadd aa16 aa8))
(setq aa4 aa16)
)
(setvar "OSMODE" 0)
(setvar "LTSCALE" 0.0001)
(while (setq aa9 (tblnext "Layer" aa17))
(setq aa17 nil)
(if (= (cdr (assoc 70 aa9)) 4)
(vl-cmdf "_.'layer" "_u" (cdr (assoc 2 aa9)) "")
)
)
(command "_.imageframe" 1
"_.shademode" 2
"_.zoom" "_o" aa16 ""
"_.wipeout" "_f" "_on"
"_.regen"
"_.offset" (/ (getvar "VIEWSIZE") 5e3) aa16 (getvar "VSMAX") ""
"_.zoom" "_o" (setq aa5 (entlast) aa6 aa5) "")
(setvar "EXPLMODE" 1)
(mapcar '(lambda (q)
(if (= (car q) 3)
(command "_-group" "_e" (cdr q)))
)(dictsearch (namedobjdict) "ACAD_GROUP"))
(if (not (equal (last aa1)(car aa1) 1e-6))
(setq aa1 (cons (last aa1) aa1)))
(if (= aa15 2)(progn
(setq aa3 (ssget "_F" aa1 '((0 . "INSERT")))
aa9 aa6)
(if aa3
(repeat (setq aa7 (sslength aa3))
(setq aa10 (ssname aa3 (setq aa7 (1- aa7)))
aa11 (entget aa10))
(command "_.xclip" aa10 "" "_n")
(if (and (setq aa11 (member '(102 . "{ACAD_XDICTIONARY") aa11))
(setq aa11 (cdr aa11))
(setq aa10 (cdr (assoc 360 aa11)))
(setq aa11 (entget aa10))
(assoc 360 (member '(3 . "ACAD_FILTER") aa11))
)
(command "_y")
)
(command "_p")
(repeat (setq aa10 (length aa1))
(command (nth (setq aa10 (1- aa10)) aa1))
)
(command "")
))
)
(if (= aa15 1)
(while aa3
; Блоки расчленить: "_CP" - все в выбранной области, "_F" - на границе:
(setq aa3 (ssget "_F" aa1 '((0 . "INSERT")))
aa9 aa6)
(if aa3
(repeat (setq aa7 (sslength aa3))
(setq aa10 (ssname aa3 (setq aa7 (1- aa7)))
aa11 (entget aa10))
(if (= (cdr (assoc 1 (entget (tblobjname "block" (cdr (assoc 2 aa11)))))) "")(progn
(setq aa17 '()
aa12 (entget (tblobjname "layer" (cdr (assoc 8 aa11))))
aa17 (cons (list (assoc 370 aa11)
(assoc 370 aa12)) aa17)
aa17 (cons (list (assoc 6 aa11)
(assoc 6 aa12)) aa17)
aa17 (cons (list (assoc 62 aa11)
(assoc 62 aa12)) aa17)
aa12 aa10
aa13 '())
(if (= (cdr (assoc 66 aa11)) 1)(progn
;(command "_.attsync" "_s" aa10 "_y")
(while (/= "SEQEND" (cdr (assoc 0 aa11)))
(if (= (cdr (assoc 0 aa11)) "ATTRIB")(progn
(setq aa14 '())
(foreach aa15 '(2 1 7 8 10 11 39 40 41 50 51 62 71 73 370)(progn
(if (/= (assoc aa15 aa11) nil)
(setq aa14 (append aa14 (list (assoc aa15 aa11)))))))
(setq aa13 (cons aa14 aa13))
))
(setq aa12 (entnext aa12)
aa11 (entget aa12))
)
))
(command "_.explode" aa10)
(while (entnext aa9)
(setq aa9 (entnext aa9)
aa11 (entget aa9)
aa12 (entget (tblobjname "layer" (cdr (assoc 8 aa11)))))
(if (= (setq aa15 (cdr (setq aa14 (assoc 62 aa11)))) 0)
(if (setq aa15 (car (nth 0 aa17)))
(entmod (setq aa11 (subst aa15 aa14 aa11)))
(entmod (setq aa11 (subst (cadr (nth 0 aa17)) aa14 aa11)))
)
(if (null aa15)
(entmod (setq aa11 (append aa11 (list (assoc 62 aa12)))))
))
(if (and (setq aa15 (cdr (setq aa14 (assoc 6 aa11))))(= (strcase aa15) "BYBLOCK"))
(if (setq aa15 (car (nth 1 aa17)))
(entmod (setq aa11 (subst aa15 aa14 aa11)))
(entmod (setq aa11 (subst (cadr (nth 1 aa17)) aa14 aa11)))
)
(if (null aa15)
(entmod (setq aa11 (append aa11 (list (assoc 6 aa12)))))
))
(if (= (setq aa15 (cdr (setq aa14 (assoc 370 aa11)))) -2)
(if (setq aa15 (car (nth 2 aa17)))
(entmod (setq aa11 (subst aa15 aa14 aa11)))
(entmod (setq aa11 (subst (cadr (nth 2 aa17)) aa14 aa11)))
)
(if (null aa15)
(entmod (setq aa11 (append aa11 (list (assoc 370 aa12)))))
))
(if (= (cdr (assoc 0 aa11)) "ATTDEF")(progn
(setq aa8 (ssadd aa9 aa8)
aa14 (assoc 2 aa11)
aa15 (cdr (assoc aa14 aa13)))
(if aa15 (if (/= (vl-string-trim " " (cdar aa15)) "")(progn
(if (setq aa14 (assoc 370 aa11))
(if (null (assoc 370 aa15))
(setq aa15 (append aa15 (list aa14)))
))
(entmake (cons '(0 . "TEXT") aa15))
)))
))
))(progn
(command "_.xclip" aa10 "" "_n")
(if (and (setq aa11 (member '(102 . "{ACAD_XDICTIONARY") aa11))
(setq aa11 (cdr aa11))
(setq aa10 (cdr (assoc 360 aa11)))
(setq aa11 (entget aa10))
(assoc 360 (member '(3 . "ACAD_FILTER") aa11))
)
(command "_y")
)
(command "_p")
(repeat (setq aa10 (length aa1))
(command (nth (setq aa10 (1- aa10)) aa1))
)
(command "")
))
))
(setq aa3 nil)
(while (entnext aa6)
(setq aa6 (entnext aa6)
aa3 T)
)
)
)
)
(if (setq aa3 (ssget "_F" aa1 '((-4 . "<OR")
(0 . "ACAD_TABLE")
;;; (0 . "*DIMENSION")
;;; (0 . "LEADER")
(-4 . "OR>")
)))
(repeat (setq aa7 (sslength aa3))
(command "_.explode" (ssname aa3 (setq aa7 (1- aa7))))
))
(if (setq aa12 (ssadd)
aa3 (ssget "_CP" aa1 '((0 . "HATCH"))))(progn
(setq aa6 (entlast)
aa7 (sslength aa3))
(repeat aa7
(setq aa10 (ssname aa3 (setq aa7 (1- aa7)))
aa9 (assoc 450 (entget aa10)))
(if (= (cdr aa9) 1)
(entmod (subst (cons 450 0) aa9 (entget aa10))))
(command "_-hatchedit" aa10 "_b" "_r" "_n")
(if (null (entnext aa6))(progn
(command "_-hatchedit" aa10 "_b" "_p" "_n"
"_-hatchedit" aa10 "_di"
"_-hatchedit" aa10 "_as" "_s")
(while (entnext aa6)
(setq aa6 (entnext aa6)
aa8 (ssadd aa6 aa8)
)
(command aa6)
)
(command "" ""
"_-hatchedit" aa10 "_b" "_r" "_n")
))
(if (entnext aa6)(progn
(setq aa6 (entnext aa6)
aa8 (ssadd aa6 aa8)
aa12 (ssadd aa6 aa12)
)
(command "_-hatchedit" aa10 "_di"
"_-hatchedit" aa10 "_as" "_s" aa6 "" "")
))
(if (= (cdr aa9) 1)(progn
(setq aa9 (entget aa10))
(entmod (subst (cons 450 1) (assoc 450 aa9) aa9))
))
)
))
(if (setq aa3 (ssget "_CP" aa1 '((0 . "REGION"))))
(repeat (setq aa11 (sslength aa3))
(setq aa11 (1- aa11)
aa12 (ssadd (ssname aa3 aa11) aa12))
))
(if (> (sslength aa12) 0)(progn
(command "_.copy" aa4 "" '(0 0 0) '(0 0 0)
"_.region" (entlast) "")
(setq aa7 (sslength aa12)
aa6 (entlast)
aa8 (ssadd aa6 aa8))
(repeat aa7
(command "_.copy" aa6 "" '(0 0 0) '(0 0 0))
(setq aa8 (ssadd (entlast) aa8))
(command "_.intersect" (ssname aa12 (setq aa7 (1- aa7))) (entlast) "")
)
))
(if (setq aa3 (ssget "_X" '((0 . "IMAGE,WIPEOUT"))))
;;;(if (setq aa3 (ssget "_CP" aa1 '((0 . "IMAGE,WIPEOUT"))))
(repeat (setq aa7 (sslength aa3))
(setq aa6 (ssname aa3 (setq aa7 (1- aa7)))
aa9 (entget aa6)
aa10 (cdr (assoc 10 aa9))
aa11 (cdr (assoc 11 aa9))
aa12 (cdr (assoc 12 aa9))
aa14 (cdr (assoc 13 aa9)))
(if (or (= (logand (cdr (assoc 70 aa9)) 4) 0)(< (cdr (assoc 91 aa9)) 3))
(setq aa9 (list '(14 0 0)
(list 14 0 (cadr aa14))
(list 14 (car aa14) (cadr aa14))
(list 14 (car aa14) 0)
'(14 0 0))
aa14 (list 0 (cadr aa14)))
(setq aa14 (list -0.5 (- (cadr aa14) 0.5))))
(setvar "DELOBJ" 1)
(apply 'command (cons "_.pline"
(vl-remove nil
(mapcar ' (lambda (q)
(if (= (car q) 14)
(progn
(setq aa13 (cdr q)
aa13 (mapcar '- aa13 aa14)
aa13 (mapcar '- (mapcar '* aa11 (list (car aa13)
(car aa13)))
(mapcar '* aa12 (list (cadr aa13)(cadr
aa13))))
aa13 (mapcar '+ aa10 aa13))
(trans aa13 0 1)
;(command (trans aa13 0 1))
);progn
);if
);lambda
aa9);mapcar
)
)
)
;(command "_.pline")
;(mapcar '(lambda (q)
;(if (= (car q) 14)(progn
;(setq aa13 (cdr q)
; aa13 (mapcar '- aa13 aa14)
; aa13 (mapcar '- (mapcar '* aa11 (list (car aa13)(car aa13)))
; (mapcar '* aa12 (list (cadr aa13)(cadr aa13))))
; aa13 (mapcar '+ aa10 aa13))
;(command (trans aa13 0 1))
;))
;) aa9)
(command "_u" "_c"
"_.region" (entlast) "")
(setvar "DELOBJ" 0)
(setq aa10 (entlast))
(if (= (cdr (assoc 0 (entget aa10))) "REGION")(progn
(command "_.region" aa16 ""
"_.intersect" aa10 (entlast) "")
(if (eq aa10 (entlast))(progn
(command "_.explode" aa10)
(setq aa9 nil
aa12 (ssadd))
(if (= (cdr (assoc 0 (entget (entlast)))) "REGION")
(while (entnext aa10)
(setq aa12 (ssadd (setq aa10 (entnext aa10)) aa12))
)(progn
(command "_.undo" 1)
(setq aa12 (ssadd aa10 aa12))
))
(repeat (setq aa14 (sslength aa12))
(command "_.explode" (ssname aa12 (setq aa14 (1- aa14)))
"_.pedit" (setq aa10 (entnext aa10)) "_y" "_j")
(while (setq aa10 (entnext aa10))
(command aa10))
(command "" "")
(setq aa11 (entlast)
aa10 (entget aa11)
aa9 '())
(mapcar '(lambda (q)
(if (= (car q) 10)
(setq aa9 (cons (trans (cdr q) 0 1) aa9)))
) aa10)
(if (equal (last aa9) '(0 0 0) 1e-6)
(setq aa9 (reverse aa9)))
(if (= (cdr (assoc 0 (entget aa6))) "IMAGE")(progn
(command "_.copy" aa6 "" '(0 0 0) '(0 0 0)
"_.imageclip" (entlast) "_d"
"_.imageclip" (entlast) "_n" "_p")
(repeat (setq aa10 (length aa9))(command (nth (setq aa10 (1- aa10)) aa9)))
(command "_c")
)
(command "_.wipeout" "_p" aa11 "_y"
"_.matchprop" aa6 (entlast) "")
)
(setq aa8 (ssadd aa11 aa8)
aa10 (entlast))
)
(setq aa8 (ssadd aa6 aa8))
))
)
(command "_.erase" aa10 "")
)
))
(setq aa3 (ssget "_CP" aa1)
aa6 '())
(mapcar '(lambda (q)
(if (= (car q) 10)
(setq aa6 (cons (trans (cdr q) 0 1) aa6)))
)(entget aa5))
(setq aa6 (cons (last aa6) aa6))
(if aa3 (command "_.move" aa3 "" '(0 0 0) '(0 0 0)))
(repeat 4
(command "_.trim" aa4 "" "_f")
(repeat (setq aa5 (length aa6))
(command (nth (setq aa5 (1- aa5)) aa6))
)
(while (= (getvar 'cmdactive) 1)(command ""))
)
(setq aa10 (entdel aa4))
(if (setq aa5 (ssget "_CP" aa6 '((0 . "*POLYLINE"))))(progn
(vl-cmdf "_.pedit" "_m" aa5 "" "_w" 0 "")
(setq aa5 (ssget "_F" aa6 '((0 . "*POLYLINE"))))
(command "_.undo" 1)
))
(setq aa9 (ssget "_F" aa6 '((-4 . "<OR")
(0 . "LINE")
(0 . "*DIMENSION");Без размеров
(-4 . "OR>")
)))
(entdel aa10)
(command "_.erase" aa8)
(if aa9 (command aa9 ))
(if aa5 (command aa5 ))
(command "")
(if (= aa18 1)
(setq aa3 (ssget "_CP" aa6 '((-4 . "<NOT")(0 . "MTEXT,*LEADER")(-4 . "NOT>")))
aa11 (ssget "_CP" aa6 '((0 . "MTEXT,*LEADER"))))
(setq aa3 (ssget "_CP" aa6)
aa11 nil)
)
(setq aa12 '()
aa10 (getvar "FIELDEVAL")
aa6 "Fragm_1")
(if aa11 (repeat (setq aa13 (sslength aa11))
(setq aa13 (1- aa13)
aa14 (entget (ssname aa11 aa13) '("ACAD"))
;;; aa14 (vl-remove (assoc -1 aa14) aa14)
aa12 (cons aa14 aa12))
))
(while (or (tblsearch "block" aa6)
(findfile (setq aa1 (strcat (getvar "tempprefix") aa6 ".dwg"))))
(setq aa6 (substr aa6 7)
aa6 (itoa (1+ (atoi aa6)))
aa6 (strcat "Fragm_" aa6))
)
(if aa3 (progn
(command "_.draworder" aa4 "" "_f"
"_.wblock" aa1 "" (trans aa2 0 1) aa3 aa4 ""
"_.undo" "_b"
"_fieldeval" 0
"_.regenall"
"_.insert" aa1 "_none" (trans aa2 0 1))
(while (= (getvar 'cmdactive) 1)
(command ""))
(vl-file-delete aa1)
(setq aa2 (trans aa2 0 1)
aa3 1.0
aa11 (ssadd (entlast) (ssadd)))
(repeat (setq aa13 (length aa12))
(setq aa13 (1- aa13)
aa1 (nth aa13 aa12))
(if (/= (cdr (assoc 70 (tblsearch "Layer" (cdr (assoc 8 aa1))))) 4)(progn
(entmake aa1)
(entmod (entget (entlast)))
(setq aa11 (ssadd (entlast) aa11))
))
)
;;;(vl-cmdf "_.copyclip" aa11 "")
(while aa2
(vl-cmdf "_.move" aa11 "" "_none" aa2)
(princ "\nУкажите положение фрагмента или <Настроить>:")
(setq aa1 (vl-cmdf pause)
aa8 (getvar 'lastprompt))
(if aa1
(if (equal aa2 (getvar "LASTPOINT") 1e-6)(progn
(if (setq aa1 (vl-string-search ">:" aa8))
(setq aa1 (substr aa8 (+ aa1 3))))
(if (= aa1 "0")
(setq aa2 nil)(progn
(command "_.move" aa11 "" aa2 '(0 0 0)
"_.move" aa11 "" aa2 (setq aa2 (cadr (grread 1 1))))
(princ (strcat "\nМасштаб или <" (nth aa18 '("Примитивами" "Блоком")) ", масштаб "))
(princ aa3)(princ ">:")
(initget 128)
(if (vl-catch-all-error-p
(setq aa7 (vl-catch-all-apply 'getkword)))
(setq aa7 ""))
(if (null aa7)(setq aa7 "" aa18 (abs (1- aa18))))
(setq aa7 (vl-string-translate ",:" "./" aa7)
aa4 (atof aa7))
(if (setq aa5 (vl-string-search "/" aa7))
(if (= (setq aa5 (atof (substr aa7 (+ aa5 2)))) 0)
(setq aa4 aa3)
(setq aa4 (/ aa4 aa5))
))
(if (= aa4 0)(setq aa4 aa3))
(setq aa7 (* (/ 1.0 aa3) aa4)
aa3 aa4)
(vl-cmdf "_.scale" aa11 "" "_none" aa2 aa7)
)))
(setq aa2 nil)
)
(setq aa2 nil
aa8 nil)
)
)
(if (= aa18 1)(progn
(setq aa4 (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object)))
aa1 (getvar "EXPLMODE")
aa5 (entlast)
aa18 (nth 3 aa19)
aa7 (ssadd))
(setvar "EXPLMODE" 1)
(command "_.explode" (ssname aa11 0))
(setvar "EXPLMODE" aa1)
(if (eq (type (vl-catch-all-apply 'vla-Item (list aa4 aa6))) 'VLA-OBJECT)
(vl-catch-all-apply 'vla-Delete (list (vla-Item aa4 aa6))))
(if (and aa19 (/= aa3 1))
(while (entnext aa5)
(setq aa5 (entnext aa5)
aa1 (entget aa5 '("ACAD"))
aa2 (cdr (assoc 0 aa1)))
(if (/= (cdr (assoc 70 (tblsearch "Layer" (cdr (assoc 8 aa1))))) 4)(progn
(cond
((and (= aa2 "HATCH")(= (nth 0 aa19) 1))
(if (setq aa2 (assoc 41 aa1))(progn
(entmod (subst (cons 41 (/ (cdr aa2) aa3)) aa2 aa1))
(command "_-hatchedit" aa5 "_p")
(while (= (getvar 'cmdactive) 1)(command ""))
))
)
((and (wcmatch aa2 "*POLYLINE")(= (nth 1 aa19) 1))
(if (setq aa2 (assoc 43 aa1))
(vl-cmdf "_.pedit" "_m" aa5 "" "_w" (/ (cdr aa2) aa3) "")
)
)
((and (wcmatch aa2 "*DIMENSION")(= (nth 2 aa19) 1))
(setq aa1 (entget aa5 '("ACAD"))
aa2 (cadr (assoc -3 aa1))
aa2 (member (cons 1070 '144) aa2))
(if aa2
(setq aa2 (cdadr aa2))
(setq aa1 (cdr (assoc 3 aa1))
aa1 (tblobjname "DIMSTYLE" aa1)
aa2 (cdr (assoc 144 (entget aa1))))
)
(if (null aa2)(setq aa2 1.))
(command "_.dimoverride" "DIMLFAC" (/ aa2 aa3) "" aa5 "")
(if (and (> aa18 0)(< aa18 256))(setq aa7 (ssadd aa5 aa7)))
)
)
))
)
)
(if (> (sslength aa7) 0)(command "_.change" aa7 "" "_p" "_c" aa18 ""))
))
(setvar "FIELDEVAL" aa10)
)
(command "_.undo" "_b")
)
))
(setvar "CMDECHO" 1)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(if (null aa8)(command "_.undo" 1))
)
(princ "\nДля AutoCAD с 2006 версии")
)
(princ)
)
VVA пишет:Если ты про > VVA (2007-06-20 16:39:05), то в этом коде не обрабатывается случай, когда в текущем текстовом стиле задана высота, отличная от 0.
Вариант с учетом высоты текстового стиля, привязок, ПСК
Автоматическая нумерация поворотных точек участка
ideal-a пишет: Приложение скомпилированно в VLX и устанавливается инсталлятором
А если приложение скомпилировать в fas? Далее все то же самое
Шелдон Шелдон пишет:работает но не хочет выбирать обьект, помогите
В посте #30 есть пояснение к коду
Обрабатывает Rotated или Aligned размеры.
Скорее всего у тебя линейный горизонтальный или вертикальный размер
Виталич Круглов пишет:Дело в том, что у меня объекты есть группы..они состоят из вхождения блока и из нескольких наборов примитивов, типы которых могут быть различны
Можно использовать связку расширенных данные + словари. В фильтре Функции ssget можно использовать группу -3 для выбора примитивов с определенным именем расширенных данных
Пример здесь, начиная с поста #30
А ничего усовершенствовать не нужно
1. Берем отсюда LISP.Выделение объектов в области контура или отсюда Выделение объектов в области контура, AutoCAD команды SCWP или SCCP
2. Выделяем и их помощью объекты внутри контура
3. Используем MAREA42
[FONT=Arial]!!! Обращаем внимание на то, что системная переменная PICKFIRST должна быть = 1[/FONT]
Еще вариант
;;; http://www.theswamp.org/index.php?topic=30660.0
;;; Entsel/NEntsel with display of layer name of object on mouse over and optional keyword
;;; #Nested - T for nested selection, nil if not
;;; #Prompt - Prompt string to display, when not displaying object's layer name
;;; #Keywords - Comma delimited key letters or nil to ignore (ie: "A,b" to match A, a, B or b
;;; Alan J. Thompson, 10.20.09
;;; 10.29.09 CAB modified
(defun AT:EntselLayerDisplay
(#Nested #Prompt #Keywords / *error* #Layer #Prompt #Text #Read #Temp #Final MinPt MaxPt tStr)
(setq *error* (lambda (x) (and #Text (vl-catch-all-apply 'vla-delete (list #Text))))
#Layer (vlax-ename->vla-object (tblobjname "layer" "0"))
) ;_ setq
(or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
(or #Prompt (setq #Prompt "Select object: "))
(or (eq (getvar 'clayer) "0") (vla-put-freeze #Layer :vlax-false))
(vla-put-lock #Layer :vlax-false)
(vla-put-layeron #Layer :vlax-true)
(setq #Text (vlax-ename->vla-object
(entmakex (list '(0 . "MTEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
'(8 . "0")
;'(62 . 250) ; CAB removed
;'(90 . 1) ; CAB removed no workie in ACAD2000
;'(63 . 7) ; CAB removed no workie in ACAD2000
;'(45 . 1.3) ; CAB removed no workie in ACAD2000
(cons 40 (* (getvar "viewsize") 0.013))
(cons 50 0.0)
'(10 0 0 0);(trans (cadr (grread T 15 0)) 1 0)) ; CAB modified
) ;_ list
) ;_ entmakex
) ;_ vlax-ename->vla-object
) ;_ setq
(vl-catch-all-apply
'(lambda ()
(vlax-invoke
(vla-AddObject
(vla-GetExtensionDictionary
(if (or (eq acmodelspace (vla-get-activespace *AcadDoc*))
(eq :vlax-true (vla-get-mspace *AcadDoc*))
) ;_ or
(vla-get-modelspace *AcadDoc*)
(vla-get-paperspace *AcadDoc*)
) ;_ if
) ;_ vla-GetExtensionDictionary
"ACAD_SORTENTS"
"AcDbSortentsTable"
) ;_ vla-AddObject
'MoveToTop
(list #Text)
) ;_ vlax-invoke
) ;_ lambda
) ;_ vl-catch-all-apply
(while (and (setq #Read (grread T 15 2))
(/= (cadr #Read) 13)
(/= (car #Read) 25)
(not (vl-position (cadr #Read) '(13 158)))
(not #Final)
) ;_ and
(cond
((and (eq (car #Read) 2)(eq 9 (cadr #Read)));Click <TAB> to toggle between nested and non-nested
(setq #Nested (not #Nested))
)
((eq 5 (car #Read))
(vla-put-insertionpoint
#Text
(vlax-3d-point (polar (trans (cadr #Read) 1 0)
(angle '(0 0) (trans (getvar "UCSXDIR") 0 (trans '(0 0 1) 1 0 T))) ; CAB modified
(* (getvar "viewsize") 0.02)))
) ;_ vla-put-insertionpoint
(vla-put-height #Text (* (getvar "viewsize") 0.013))
(if (setq #Ent (nentselp (cadr #Read)))
(if #Nested
(progn
(setq QQQ #Ent)
(vla-GetBoundingBox (vlax-ename->vla-object (car #Ent)) 'MinPt 'MaxPt)
(setq MinPt (vlax-safearray->list MinPt) MaxPt (vlax-safearray->list MaxPt))
(setq tStr
(strcat
"{\\C4;" (cdr (assoc 0 (entget (car #Ent)))) "}"
"\nHEIGHT: " (rtos (abs(- (cadr MaxPt)(cadr MinPt))) 2 5)
"\nWIDTH: " (rtos (abs(- (car MaxPt)(car MinPt))) 2 5)
"\nLAYER: " (cdr (assoc 8 (entget (car #Ent)))) )
)
(vla-put-textstring #Text tStr)
)
(cond
((eq (length #Ent) 2) (vla-put-textstring #Text (cdr (assoc 8 (entget (car #Ent))))))
((eq (length #Ent) 4)
(vla-put-textstring #Text (cdr (assoc 8 (entget (car (car (reverse #Ent)))))))
)
) ;_ cond
) ;_ if
(vla-put-textstring #Text #Prompt)
) ;_ if
)
((eq 3 (car #Read))
(if (setq #Temp (nentselp (cadr #Read)))
(progn
(or #Nested
(and (eq 4 (length #Temp))
(setq #Temp (list (car (car (reverse #Temp))) (cadr #Temp)))
) ;_ and
) ;_ or
(or (eq (vla-get-objectid (vlax-ename->vla-object (car #Temp)))
(vla-get-objectid #Text)
) ;_ eq
(setq #Final #Temp)
) ;_ or
) ;_ progn
) ;_ if
)
((and #Keywords (eq (car #Read) 2))
(if (wcmatch (strcase (chr (cadr #Read))) (strcase #Keywords))
(setq #Final (chr (cadr #Read)))
) ;_ if
)
) ;_ cond
) ;_ while
(*error* nil)
#Final
) ;_ defun
(defun C:TTT ()(AT:EntselLayerDisplay T NIL NIL))
(princ "\nType TTT in command line")
Модификация из #64 для подсчета ЗАМНКУТЫХ контуров
Пояснение для полилиний:
Полилиния будет считаться замкнутой, если установлено соответствующее свойство или
совпадают начальная и конечная точка с точностью до 1e-6.
;_Команда MAREA42
(defun c:MAREA42 (/ m ss clist temp)
;_Считает площади ЗАМКНУТЫХ контуров
;https://www.caduser.ru/forum/topic20298.html
; Владимир Азарко aka VVA для caduser.ru
(defun sort (lst predicate)
(mapcar '(lambda (x) (nth x lst)) (vl-sort-i lst predicate))
)
(defun combine (inlist is-greater is-equal / sorted current result)
(setq sorted (sort inlist is-greater))
(setq current (list (car sorted)))
(foreach item (cdr sorted)
(if (apply is-equal (list item (car current)))
(setq current (cons item current))
(progn
(setq result (cons current result))
(setq current (list item))
)
)
)
(cons current result)
)
(defun mlen4_1 (lst / sum_area)
(setq sum_area 0)
(foreach item (mapcar 'car lst)
(setq sum_area (+ sum_area
(if (and
(vlax-property-available-p item 'area)
(or
(vlax-curve-isClosed item)
(equal
(vlax-curve-getStartPoint item)
(vlax-curve-getEndPoint item)
1e-6
)
)
)
(vla-get-area item)
0
) ;_ if
) ;_ +
)
)
(if (not (zerop sum_area))
(princ
(strcat "\n\t" (cdar lst) " = " (rtos (* sum_area m) 2 4))
)
)
(list (cdar lst)(rtos (* sum_area m) 2 4))
)
(vl-load-com)
(if (null *M*)(setq *M* 1))
(initget 6)
(and
(princ "\nВведите маштабный коэффициент <")
(princ *M*)(princ ">: ")
(or (setq m (getreal))
(setq m *M*)
)
(setq *M* m)
(setq ss (ssget "_:L"))
(setq ss (mapcar
(function vlax-ename->vla-object)
(vl-remove-if
(function listp)
(mapcar
(function cadr)
(ssnamex ss)
) ;_ mapcar
) ;_ vl-remove-if
)
)
(mapcar '(lambda (x)
(setq temp (cons (cons x (vla-get-Layer x)) temp))
)
ss
)
(setq clist (combine temp
'(lambda (a b)
(> (cdr a) (cdr b))
)
'(lambda (a b)
(eq (cdr a) (cdr b))
)
)
)
(princ
"\n\n Общая площадь всех линейных примитивов по слоям:"
)
(setq temp (mapcar 'mlen4_1 clist))
(xls temp '("Слой" "Площадь") nil "mlen41")
)
(princ)
) ;_ defun
;|================== XLS ========================================
* Опубликовано https://www.caduser.ru/forum/topic19920.html
https://www.caduser.ru/forum/topic31444.html
https://www.caduser.ru/forum/topic31669.html
* Автор: Владимир Азарко aka VVA
* Назначение: Печать списка данных Data-list в Excell
* Для вывода создается новый лист
* Аргументы:
Data-list — список списков данных (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 ( Data-list 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 (if (= Name_list "")
(vl-filename-base(getvar "DWGNAME"))
(strcat (vl-filename-base(getvar "DWGNAME")) "&" Name_list))
col 0 cols nil)
(if (> (strlen Name_list) 26)
(setq Name_list (strcat (substr Name_list 1 10) "..." (substr Name_list (- (strlen Name_list) 13) 14))))
(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 Data-list)(setq iz_listo (car Data-list))(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 Data-list (cdr Data-list))(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))
Для подсчета площади по слоям на основе #59 Команда MAREA41
;_Команда MAREA41
(defun c:MAREA41 (/ m ss clist temp)
;https://www.caduser.ru/forum/topic20298.html
; Владимир Азарко aka VVA для caduser.ru
(defun sort (lst predicate)
(mapcar '(lambda (x) (nth x lst)) (vl-sort-i lst predicate))
)
(defun combine (inlist is-greater is-equal / sorted current result)
(setq sorted (sort inlist is-greater))
(setq current (list (car sorted)))
(foreach item (cdr sorted)
(if (apply is-equal (list item (car current)))
(setq current (cons item current))
(progn
(setq result (cons current result))
(setq current (list item))
)
)
)
(cons current result)
)
(defun mlen4_1 (lst / sum_area)
(setq sum_area 0)
(foreach item (mapcar 'car lst)
(setq sum_area (+ sum_area
(if (vlax-property-available-p item 'area)
(vla-get-area item)
0
) ;_ if
) ;_ +
)
)
(if (not (zerop sum_area))
(princ
(strcat "\n\t" (cdar lst) " = " (rtos (* sum_area m) 2 4))
)
)
(list (cdar lst)(rtos (* sum_area m) 2 4))
)
(vl-load-com)
(if (null *M*)(setq *M* 1))
(initget 6)
(and
(princ "\nВведите маштабный коэффициент <")
(princ *M*)(princ ">: ")
(or (setq m (getreal))
(setq m *M*)
)
(setq *M* m)
(setq ss (ssget "_:L"))
(setq ss (mapcar
(function vlax-ename->vla-object)
(vl-remove-if
(function listp)
(mapcar
(function cadr)
(ssnamex ss)
) ;_ mapcar
) ;_ vl-remove-if
)
)
(mapcar '(lambda (x)
(setq temp (cons (cons x (vla-get-Layer x)) temp))
)
ss
)
(setq clist (combine temp
'(lambda (a b)
(> (cdr a) (cdr b))
)
'(lambda (a b)
(eq (cdr a) (cdr b))
)
)
)
(princ
"\n\n Общая площадь всех линейных примитивов по слоям:"
)
(setq temp (mapcar 'mlen4_1 clist))
(xls temp '("Слой" "Площадь") nil "mlen41")
)
(princ)
) ;_ defun
;|================== XLS ========================================
* Опубликовано https://www.caduser.ru/forum/topic19920.html
https://www.caduser.ru/forum/topic31444.html
https://www.caduser.ru/forum/topic31669.html
* Автор: Владимир Азарко aka VVA
* Назначение: Печать списка данных Data-list в Excell
* Для вывода создается новый лист
* Аргументы:
Data-list — список списков данных (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 ( Data-list 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 (if (= Name_list "")
(vl-filename-base(getvar "DWGNAME"))
(strcat (vl-filename-base(getvar "DWGNAME")) "&" Name_list))
col 0 cols nil)
(if (> (strlen Name_list) 26)
(setq Name_list (strcat (substr Name_list 1 10) "..." (substr Name_list (- (strlen Name_list) 13) 14))))
(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 Data-list)(setq iz_listo (car Data-list))(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 Data-list (cdr Data-list))(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))
Кирилл, Во первых, программа не моя, я только привел ее здесь. Разбираться в чужом коде нет ни времени, ни желания.
Удалить "ненужные" вершины можно командой PL-VxDel из комплекта [URL=http://dwg.ru/dnl/607]pltools[/URL]
Блоки вроде бы там есть
(setq ss (ssget '((0 . "point,[B пишет:insert[/B]"))))
У блоков в качестве анализируемой точки берется точка вставки, поэтому нужно проверять, чтобы она не оказалась около луны.
Кирилл]
не получилось отобарзить как у Вас
В гугле по запросу "хостинг картинок" найдешь много сайтов, куда можно закачать картинку, а здесь привести код. Я использовал [URL=http://fastpic.ru/]этот[/URL]
PS Ты закачал так же на хостинг, но копировать сюда нужно было не первую ссылку, а 2-ю или 3-ю ([B]Полная картинка[/B] или [B]Превью - увеличение по клику[/B])
Что-то наподобие этого?
(Challenge) To draw the shortest lwpolyline
;;;------------------------TSP------------------------------------------------------------;;;
;;;---------------------------------------------------------------------------------------;;;
(defun c:test (/ foo f2 ptl lst l n i d0 l0 l1 d1)
;;by GSLS(SS)
;;refer ElpanovEvgeniy's method from http://www.theswamp.org/index.php?topic=30434.75
;;2012-8-10
(defun foo (l / D D0 D1)
(setq l0 (mapcar (function list) (cons (last l) l) l)) ;_ setq
;_ defun
(setq d0 (get-closedpolygon-length l))
(while
(> d0
(progn
(foreach a l0
(setq d (get-closedpolygon-length l))
(setq l1 (vl-remove (car a) (vl-remove (cadr a) l)))
(setq l1 (f1 (car a) l1))
(setq l1 (f1 (cadr a) l1))
(if (> d
(setq d1 (get-closedpolygon-length l1))
)
(setq d d1
l l1
) ;_ setq
) ;_ if
(setq l1 (vl-remove (car a) (vl-remove (cadr a) l)))
(setq l1 (f1 (cadr a) l1))
(setq l1 (f1 (car a) l1))
(if (> d
(setq d1 (get-closedpolygon-length l1))
)
(setq d d1
l l1
)
)
)
d
) ;_ progn
) ;_ <
(setq d0 d)
) ;_ while
(setq d (get-closedpolygon-length l))
l
)
(defun f1 (a l)
(ins-lst a (get-closest-i l a) l)
)
(defun f2 (lst)
(mapcar (function (lambda (p0 p p1 / a)
(setq a (- (angle p p0) (angle p p1)))
(if (< a (- pi))
(abs (+ a pi pi))
(if (> a pi)
(abs (- a pi pi))
(abs a)
)
)
)
)
(cons (last lst) lst)
lst
(reverse (cons (car lst) (reverse (cdr lst))))
)
)
(setq ptl (my-getpt)
ptl (mapcar (function (lambda (p) (list (car p) (cadr p)))) ptl)
)
(setq t1 (getvar "MilliSecs"))
(setq lst (Graham-scan ptl))
(foreach a lst
(setq ptl (vl-remove a ptl))
)
(while (and (> (length ptl) 2) (setq l (Graham-scan ptl)))
(foreach p l
(setq ptl (vl-remove p ptl))
(setq n (get-minadddist-i lst p))
(setq lst (ins-lst p n lst))
)
)
(if ptl
(foreach p ptl
(setq n (get-minadddist-i lst p))
(setq lst (ins-lst p n lst))
)
)
(setq lst (foo lst))
(setq l (f2 lst))
(setq i 0
l0 lst
n (length lst)
d0 (get-closedpolygon-length lst)
)
(foreach a l
(if (and (< a _pi3) (= (setq p (nth i lst)) (nth i l0)))
(progn
(if (= i 0)
(setq p0 (last lst))
(setq p0 (nth (1- i) lst))
)
(if (= i (1- n))
(setq p1 (car lst))
(setq p1 (nth (1+ i) lst))
)
(setq m (list (list p0 p1 p)
(list p1 p p0)
(list p1 p0 p)
(list p p0 p1)
(list p p1 p0)
)
)
(setq l1
(car (vl-sort (mapcar (function (lambda (x)
(ch-para-lst x i lst)
)
)
m
)
(function (lambda (e1 e2)
(< (get-closedpolygon-length e1)
(get-closedpolygon-length e2)
)
)
)
)
)
)
(setq d1 (get-closedpolygon-length l1))
(if (< d1 d0)
(setq d0 d1
lst l1
)
)
)
)
(setq i (1+ i))
)
(setq l (f2 lst))
(setq i 0
l0 lst
d0 (get-closedpolygon-length lst)
)
(foreach a l
(if (and (< a _pi2) (setq p (nth i l0)))
(progn
(setq l1 (f1 p (vl-remove p lst)))
(setq d1 (get-closedpolygon-length l1))
(if (< d1 d0)
(setq d0 d1
lst l1
)
)
)
)
(setq i (1+ i))
)
(entmake
(append (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(8 . "temp")
'(62 . 1)
'(100 . "AcDbPolyline")
(cons 90 (length lst))
'(70 . 1)
)
(mapcar (function (lambda (p) (cons 10 p))) lst)
)
)
(setq t2 (getvar "MilliSecs"))
(princ (strcat "\nTSP Length :" (rtos d0 2 0) "."))
(princ (strcat "\nUse Time :" (rtos (- t2 t1) 2 0) "ms."))
(princ)
)
;;;Use Funtions
;;;--------------------------------------------------------------
;; Convex hull of pts , Graham scan method
;; by Highflybird
(defun Graham-scan (ptl / hPs rPs PsY Pt0 sPs P Q)
(if (< (length ptl) 4) ;3???
ptl ;????
(progn
(setq rPs (mapcar (function (lambda (x)
(if (= (length x) 3)
(cdr x) x)))
(mapcar 'reverse ptl));_???X?Y??
PsY (mapcar 'cadr ptl) ;_???Y???
Pt0 (reverse (assoc (apply 'min PsY) rPs)) ;_?????
sPs (sort-ad ptl Pt0) ;_?????????
hPs (list (caddr sPs) (cadr sPs) Pt0) ;_?????
)
(foreach n (cdddr sPs) ;??4???
(setq hPs (cons n hPs) ;?Pi?????
P (cadr hPs) ;Pi-1
Q (caddr hPs) ;Pi-2
)
(while (and q (> (det n P Q) -1e-6)) ;????
(setq hPs (cons n (cddr hPs)) ;??Pi-1?
P (cadr hPs) ;????Pi-1?
Q (caddr hPs) ;????Pi-2?
)))
hPs ;????
))
)
;;;?????????,???????????
(defun sort-ad (pl pt)
(vl-sort pl
(function (lambda (e1 e2 / an1 an2)
(setq an1 (angle pt e1)
an2 (angle pt e2))
(if (equal an1 an2 1e-6);_??????,???????
(< (distance pt e1) (distance pt e2))
(< an1 an2)
))))
)
;;????????,???????
(defun det (p1 p2 p3)
(- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (car p3) (car p1)) (- (cadr p2) (cadr p1)))
))
;;;
;;;------------------------
(defun my-getpt (/ ss i en l)
(setq ss (ssget '((0 . "point,insert"))))
(setq i -1)
(while (setq en (ssname ss (setq i (1+ i))))
(setq l (cons (cdr (assoc 10 (entget en))) l))
)
)
;;;------------------------
;;;
;;(ins-lst 10 5 '(1 2 3 4 5))
;; i ?????????
(defun ins-lst (new i lst / len fst)
(cond
((minusp i)
lst
)
((> i (setq len (length lst)))
lst
)
((> i (/ len 2))
(reverse (ins-lst new (- len i) (reverse lst)))
)
(t
(append
(progn
(setq fst nil)
(repeat (rem i 4)
(setq fst (cons (car lst) fst)
lst (cdr lst)
)
)
(repeat (/ i 4)
(setq fst (cons (cadddr lst)
(cons (caddr lst)
(cons
(cadr lst)
(cons
(car lst)
fst
)
)
)
)
lst (cddddr lst)
)
)
(reverse fst)
)
(list new)
lst
)
)
)
)
;;;------------------------
;;
;;(ch-para-lst '(7 8 9) 3 '(1 2 3 4 5))
(defun ch-para-lst (para i lst / len fst)
(setq len (length lst))
(cond
((minusp i)
lst
)
((> i (1- len))
lst
)
((= i 0)
(cons (cadr para)
(cons (caddr para)
(reverse (cons (car para) (cdr (reverse (cddr lst)))))
)
)
)
((= i (1- len))
(reverse
(append (cdr (reverse para))
(cddr (reverse (cons (last para) (cdr lst))))
)
)
)
((> i (/ len 2))
(reverse
(ch-para-lst (reverse para) (- len i 1) (reverse lst))
)
)
(t
(append
(progn
(setq fst nil)
(repeat (rem i 4)
(setq fst (cons (car lst) fst)
lst (cdr lst)
)
)
(repeat (/ i 4)
(setq fst (cons (cadddr lst)
(cons (caddr lst)
(cons
(cadr lst)
(cons
(car lst)
fst
)
)
)
)
lst (cddddr lst)
)
)
(reverse
(cons (caddr para)
(cons (cadr para) (cons (car para) (cdr fst)))
)
)
)
(cdr lst)
)
)
)
)
;;;------------------------
;;
(defun get-minadddist-i (lst p)
(car
(vl-sort-i
(mapcar (function (lambda (p1 p2)
(- (+ (distance p p1) (distance p p2))
(distance p1 p2)
)
)
)
(cons (last lst) lst)
lst
)
'<
)
)
)
;;;------------------------
(defun get-closest-i (lst p)
(car
(vl-sort-i
(mapcar
(function
(lambda (p1 p2 / pt d d1 d2)
(setq pt (inters p
(polar p (+ (/ pi 2.) (angle p1 p2)) 1.)
p1
p2
nil
)
d (distance p1 p2)
d1 (distance p p1)
d2 (distance p p2)
)
(if pt
(if (equal (+ (distance pt p1) (distance pt p2)) d 1e-8)
(distance p pt)
d2
)
1e99
)
)
)
(cons (last lst) lst)
lst
)
'<
)
)
)
;;;------------------------
;;
(defun get-closedpolygon-length (l)
(apply (function +)
(mapcar (function (lambda (p1 p2)
(distance p1 p2)
)
)
(cons (last l) l)
l
)
)
)
В этой теме 2 ссылки. Во второй как раз и меняются пути xref и растров
(vl-load-com)
(setq doc (vla-get-activedocument (vlax-get-acad-object)) xreflist nil)
(vlax-for item (vla-get-Blocks doc)
(if (= (vla-get-IsXref item) :vlax-true)
(setq xreflist (cons (list(vla-get-name item)(vla-get-path item)) xreflist))
)
)
(princ "\nСписок внешних ссылок " )(princ xreflist) и
(mapcar
'(lambda(a)
(cond ((= (car a) 3)(cdr a))
((= (car a) 350)
(cdr(assoc 1 (entget (cdr a))))
)
(t nil)
)
)
(vl-remove-if-not
(function (lambda (x) (member (car x) '(3 350))))
(dictsearch (namedobjdict) "ACAD_IMAGE_DICT")
)
)
Ольга пишет:Вставила уже готовый блок в котором есть полярный параметр
...
как получить доступ к этому параметру?
LISP. Изменение свойств(а) динамических блоков.
Здесь читал? HPDRAWORDER
HPDRAWORDER
Связанные разделы
Тип: Целый
Сохранен в: Не сохранен
Начальное значение: 3
Управляет порядком прорисовки штриховки или заливки.
Управление отображением объектов штриховки и заливки: впереди или позади всех других объектов либо впереди или позади связанных с ними контуров.
0 - "Нет. Для порядка прорисовки не назначается штриховка или заливка.
1 - На задний план. Штриховка или заливка помещается на задний план всех остальных объектов.
2 - На передний план. Штриховка или заливка помещается на передний план всех остальных объектов.
3 - За контуром. Штриховка или заливка помещается за объектами контуров.
4 - Перед контуром. Штриховка или заливка помещается перед объектами контуров штриховки.
Когда-то помогал делать курсовую. Программно распознаются:
1. Параллелограмм (и его разновидности ромб, квадрат, прямоугольник)
2. Трапеция
3. Треугольник (и его разновидности равносторонний, равнобедренный, прямоугольный)
4. Круг (состоящий из 2-х дуговых сегментов полилинии)
Сдабдил достаточно подробными (надеюсь) коментариями
;;;Тексты отрисовываются текущей высотой
;;;Чтобы изменить высоту текста, нужно в командной строке набрать
;;; TEXTSIZE и задать нужную высоту текста
(defun C:DZ8 (/ el pt en lst dst)
(setvar "CMDECHO" 0)
(if (getvar "PLINETYPE")
(setvar "PLINETYPE" 2)
) ;_ end of if
(while (and
(setq el (entlast)) ;_ Запоминаем последний примитив
(setq pt (getpoint "\nУкажите точку внутри области <выход>: "))
) ;_ end of and
(command "_-BOUNDARY" "_A" "_I" "_N" "_N" "_O" "_P" "" pt "") ;_ end of command
;_ end of command
(while (> (getvar "CMDACTIVE") 0) (command ""))
(setq en (entlast))
(cond
((equal el en)
;;Контур не создан
(alert "Точка вне контура")
)
((and (not (equal en el)) ;_ Контур создан
(= (cdr (assoc 0 (entget en))) "LWPOLYLINE") ;_ Контур полилиния
) ;_ end of and
;;;Анализируем контур
;;;В lst координаты полилинии
(setq lst (massoc 10 (entget en)))
(cond
((= (length lst) 4)
;;;Какой-то 4 угольник
;;;Какой?
(cond
;;;Параллелограмм?
;;;Признак параллелограмма - 4 угольник, у которого противолежащие стороны параллельны
((and (parallelp (nth 0 lst)
(nth 1 lst)
(nth 2 lst)
(nth 3 lst)
) ;_ end of parallelp
(parallelp (nth 1 lst)
(nth 2 lst)
(nth 0 lst)
(nth 3 lst)
) ;_ end of parallelp
) ;_ end of and
;;;Провереряем не является ли параллелограмм ромбом или квадратом
(if
;;;Ромб - параллелограмм, диагонали которого пересекаются под прямым углом
(equal
(3d_angw1w2
(mapcar '- (nth 0 lst) (nth 2 lst)) ;_ Формируем 1-й вектор
(mapcar '- (nth 1 lst) (nth 3 lst)) ;_ Формируем 2-й вектор
) ;_ end of 3d_angw1w2
(* PI 0.5)
1e-6 ;_ С точностью до 6 знаков после запятой
) ;_ end ofequal
;;;Да, это ромб (квадрат частный случай ромба)
;;;Квадрат - это ромб, все стороны которого равны
(if
(and
(setq dst ;_ Список длин сторон
(mapcar 'distance
(append lst (list (car lst)))
(cdr (append lst (list (car lst))))
) ;_ end of mapcar
) ;_ end of setq
(apply
'and
(mapcar '(lambda (x) (equal (car dst) x 1e-6)) dst)
) ;_ end of apply
;;Равны ли расстояния
;;;============================================================================================================
;;; Ниже идет проверка, что все углы равны 90 градусам
;;; - диагонали пересекаются под прямым углом
;;; - стороны равны
;;; - угол между сторонми 90 градусов
;;;============================================================================================================
(setq dst ;_ Список углов между сторонами
(mapcar '(lambda(x y)
(3d_angw1w2 x y)
)
(append
(setq dst ;;;Вектора
(mapcar '(lambda(x y)
(mapcar '- x y)
;(cons x (list y))
)
(append lst (list(car lst))) (cdr (append lst (list(car lst))))
)
)
(list (car dst))
)
(cdr (append dst (list (car dst))))
)
)
(apply 'and (mapcar '(lambda(x)(equal x (* PI 0.5) 1e-6)) dst))
;;;============================================================================================================
) ;_ end ofand
(text-draw "КВАДРАТ" pt (getvar "TEXTSIZE") 0 "_M") ;_ Это квадрат
(text-draw "РОМБ" pt (getvar "TEXTSIZE") 0 "_M") ;_ Это ромб
) ;_ end of if
;;;Проверяем, не является ли он прямоугольником
(if (and
;;;============================================================================================================
;;; Ниже идет проверка, что все углы равны 90 градусам
;;;============================================================================================================
(setq dst (get-angle-between-side lst)) ;_ Список углов между сторонами
(apply 'and (mapcar '(lambda(x)(equal x (* PI 0.5) 1e-6)) dst))
;;;============================================================================================================
)
(text-draw "ПРЯМОУГОЛЬНИК"
pt
(getvar "TEXTSIZE")
0
"_M"
) ;_ Это параллелограмм
(text-draw "ПАРАЛЛЕЛОГРАММ"
pt
(getvar "TEXTSIZE")
0
"_M"
) ;_ Это параллелограмм
)
) ;_ end of if
)
;;;Трапеция ли? Признак трапеции - 4 угольник, у которого одна пара паралленьных сторон
((or (parallelp (nth 0 lst)
(nth 1 lst)
(nth 2 lst)
(nth 3 lst)
) ;_ end of parallelp
(parallelp (nth 1 lst)
(nth 2 lst)
(nth 0 lst)
(nth 3 lst)
) ;_ end of parallelp
) ;_ end of or
(text-draw "ТРАПЕЦИЯ" pt (getvar "TEXTSIZE") 0 "_M")
)
(t (alert "Не обрабатываемый 4 угольгик"))
) ;_ end of cond
)
((= (length lst) 3) ;;;Треугольник
(setq dst (append lst (list (car lst))))
(setq dst (mapcar 'distance dst (cdr dst)))
(cond ((apply 'and (mapcar '(lambda(x)(equal (car dst) x 1e-6)) dst))
(text-draw "ТРЕУГОЛЬНИК РАВНОСТОРОННИЙ" pt (getvar "TEXTSIZE") 0 "_M")
)
((or (equal (nth 0 dst)(nth 1 dst) 1e-6)
(equal (nth 0 dst)(nth 2 dst) 1e-6)
(equal (nth 1 dst)(nth 2 dst) 1e-6)
)
(text-draw "ТРЕУГОЛЬНИК РАВНОБЕДРЕННЫЙ" pt (getvar "TEXTSIZE") 0 "_M")
)
((and (setq dst (get-angle-between-side lst)) ;_ Список углов между сторонами
(apply 'or (mapcar '(lambda(x)(equal x (* pi 0.5) 1e-6)) dst))
)
(text-draw "ТРЕУГОЛЬНИК ПРЯМОУГОЛЬНЫЙ" pt (getvar "TEXTSIZE") 0 "_M")
)
(t (text-draw "ТРЕУГОЛЬНИК" pt (getvar "TEXTSIZE") 0 "_M"))
)
)
;;; Может это круг?
;;; У полилинии 2 дуговых сегмента
;;; кривизна дуговых сегментов (поле 42) будет постоянна и равна 1
((and (setq lst (massoc 42 (entget en)))
(= (length lst) 2)
(apply '= lst)
) ;_ end of and
(text-draw "КРУГ" pt (getvar "TEXTSIZE") 0 "_M")
)
(t (alert "Не обрабатываемый контур"))
) ;_ end of cond
(if (and en (entget en))
(entdel en)
) ;_ end of if
)
(t
(if (and en (not (equal en el)) (entget en))
(entdel en)
) ;_ end of if
(alert "Не обрабатываемый контур")
)
) ;_ end of cond
) ;_ end of while
) ;_ end of defun
;;;Дополнительные функции
(defun get-angle-between-side ( lst / dst )
;;; Список углов между сторонами
;;; lst - Список координат вершин многоугольника
(mapcar '(lambda(x y)
(3d_angw1w2 x y)
)
(append
(setq dst ;;;Вектора
(mapcar '(lambda(x y)
(mapcar '- x y)
;(cons x (list y))
)
(append lst (list(car lst))) (cdr (append lst (list(car lst))))
)
)
(list (car dst))
)
(cdr (append dst (list (car dst))))
)
)
(defun text-draw (txt pnt height rotation justification)
;;;Ф-ция отрисовывает текст txt
;;; в точке pnt
;;; высотой heigth
;;; углом повотора rotation
;;; выравниванием justification
(if (null pnt)
(vl-cmdf "_.-TEXT" "" txt)
(if (= (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE"))))
0.0
) ;_ end of =
(progn
;; нулевая высота текста
(if justification
(vl-cmdf "_.-TEXT" "_J" justification
"_non" pnt height rotation
txt
) ;_ end of vl-cmdf
(vl-cmdf "_.-TEXT" "_non" pnt height rotation txt)
) ;_ end of if
) ;_ end of progn
(progn
;; фиксированнная высота
(if justification
(vl-cmdf "_.-TEXT" "_J" justification "_non" pnt rotation txt) ;_ end of vl-cmdf
;_ end ofvl-cmdf
(vl-cmdf "_.-TEXT" "_non" pnt rotation txt)
) ;_ end of if
) ;_ end of progn
) ;_ end of if
) ;_ end ofif
(entlast)
) ;_ end ofdefun
(defun massoc (key alist / x nlist)
;;; Возвращает все вхождения ключа в списке
;;; ! Argument : 'key' - DXF код
;;; ! 'alist' - Список
;;; ! Returns : Список всех значений ключа key, если есть или nil
(foreach x alist
(if (eq key (car x))
(setq nlist (cons (cdr x) nlist))
) ;_ end of if
) ;_ end offoreach
(reverse nlist)
) ;_ end of defun
(defun 3d_angw1w2 (Wekt1 Wekt2 / CosA)
;;; Угол между векторами (скалярное произведение векторов)
;;;--------------------------------------------------------
;;; Параметры:
;;; Wekt1, Wekt2 - вектора
;;; Возвращает угол между векторами в радианах
;;; http://www.elecran.com.ua/index.php?pagename=programer.php
;;;--------------------------------------------------------
(if (equal (setq CosA (/ (apply '+ (mapcar '* Wekt1 Wekt2))
(distance '(0 0 0) Wekt1)
(distance '(0 0 0) Wekt2)
) ;_ end of
) ;_ end of setq
-1.0
1e-6
) ;_ end of equal
Pi
(if (equal CosA 0.0 1e-6)
(* 0.5 PI)
(atan (sqrt (- 1 (* CosA CosA))) CosA)
) ;_ end of if
) ;_ end of if
) ;_ end of defun
(defun parallelp (p1 p2 p3 p4)
;;; PARALLELP
;;; Высисляет, параллелен ли сегмент
;;; заданный точками p1 p2 сегменту, заданному точками p3 p4
;;;
;;; Аргумент = 4 точки
(and
(not (inters p1 p2 p3 p4 nil))
(or (inters p1 p4 p3 p2 nil)
(inters p1 p3 p4 p2 nil)
) ;_ end of or
) ;_ end of and
) ;_ end of defun
Дмитрий Космос пишет:Но у вас к сожалению нет возможности сначала выбора полилинии.
Теперь есть такая возможность :)
Сообщений найдено с 1 по 25 из 1,859
Страницы 1 2 3 … 75 Далее
