Получение фрагмента чертежа по круглой границе должно происходить, если при вызове программы (в строке "Первая точка прямоугольной области или <Круглая>:") правый клик или «ENTER» или пробел. Далее версия, которая тоже уже написана давно, но т.к. пока нового в коде не чего не предвидится, то выкладываю ее.
А за благодарность спасибо, думаю, без отзывов многие программы остались бы без развития.
;|====================================================
Фрагмент чертежа по прямоуг. или кругл. границе
(программа тестировалась на AutoCAD 2006, 2008)
Программа Дениса Флюстикова "Fragm_Den" от 16.12.08
Новое:
- работа с таблицами
Макрос для кнопки:
^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)
(if (>= (atof (getvar "ACADVER")) 16.2)(progn
(setq aa8 "Размер" ;Слой построения контура
aa1 (getpoint "\nПервая точка прямоугольной области или <Круглая>:")
aa2 nil
aa6 nil)
(vl-load-com)
(if aa1
(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")
(if aa8 (if (tblsearch "Layer" aa8)(setvar "CLAYER" aa8)))
)
)(progn
(setq aa1 (getpoint "\nЦентр круглой области:"))
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")
(if aa8 (if (tblsearch "Layer" aa8)(setvar "CLAYER" aa8)))
(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)))))
(setq aa1 (+ aa1 aa5)))
))))
(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")
)
(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))
(mapcar '(lambda (q)
(if (= (car q) 10)
(setq aa1 (cons (trans (cdr q) 0 1) aa1)))
) aa7)
(if aa5
(setq aa8 (ssadd (entlast)(ssadd)))
(setq aa4 (entlast)
aa8 (ssadd))
)
(setvar "OSMODE" 0)
(setvar "LTSCALE" 0.0001)
(command "_.shademode" 2
"_.zoom" "_o" (entlast) ""
"_.offset" (/ (getvar "VIEWSIZE") 2e4)(entlast)(getvar "VSMAX") ""
"_.zoom" "_o" (setq aa5 (entlast) aa6 aa5) "")
(setvar "EXPLMODE" 1)
(while aa3
(setq aa3 (ssget "_CP" aa1 '((0 . "INSERT"))))
(if aa3
(repeat (setq aa7 (sslength aa3))
(command "_.explode" (ssname aa3 (setq aa7 (1- aa7))))
))
(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 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))
(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"))))(progn
(command "_.copy" aa4 "" '(0 0 0) '(0 0 0)
"_.region" (entlast) "")
(setq aa7 (sslength aa3)
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 aa3 (setq aa7 (1- aa7))) (entlast) "")
)
))
;;;(if (setq aa3 (ssget "_F" aa1 '((0 . "IMAGE"))))
;;;(repeat (setq aa7 (sslength aa3))
;;;(command "_.imageclip" (ssname aa3 (setq aa7 (1- aa7))) "_n" "_p")
;;;(repeat (setq aa6 (length aa1))(command (nth (setq aa6 (1- aa6)) aa1)))
;;;(command "_c")
;;;))
(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))
(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 ""))
)
(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 aa6 (ssget "_F" aa6 '((-4 . "<OR")(-4 . "<NOT")(-4 . "<OR")
(0 . "HATCH")
(0 . "*POLYLINE")
(0 . "*TEXT")
(0 . "REGION")
;;; (0 . "IMAGE")
(-4 . "OR>")(-4 . "NOT>")
(0 . "*DIMENSION,LEADER");Без размеров
(-4 . "OR>")
)))
(command "_.erase" aa8)
(if aa6 (command aa6 ))
(if aa5 (command aa5 ))
(command "")
(setq aa3 (ssget "_CP" aa1)
aa6 "den")
(while (or (tblsearch "block" aa6)
(findfile (setq aa1 (strcat (getvar "tempprefix") aa6 ".dwg"))))
(setq aa6 (strcat aa6 "1")))
(command "_.wblock" aa1 "" (trans aa2 0 1) aa3 aa4 ""
"_.undo" "_b"
"_.insert" aa1 "_none" (trans aa2 0 1))
(while (= (getvar 'cmdactive) 1)
(command ""))
(vl-file-delete aa1)
(setq aa2 (trans aa2 0 1)
aa5 (entlast)
aa3 1.0)
(while aa2
(vl-cmdf "_.move" aa5 "" "_none" aa2)
(princ (strcat "\nУкажите положение элемента или <Масштаб>:"))
(setq aa1 (vl-cmdf pause))
(if (and aa1 (equal aa2 (getvar "LASTPOINT") 1e-6))(progn
(setq aa1 (getvar 'lastprompt)
aa1 (substr aa1 (+ (vl-string-search ">:" aa1) 3)))
(if (= aa1 "0")
(setq aa2 nil)(progn
(command "_.erase" aa5 ""
"_.insert" aa6 "_none" (setq aa2 (cadr (grread 1 1))) aa3)
(while (= (getvar 'cmdactive) 1)
(command ""))
(princ "\nМасштаб <")(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 ""))
(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
aa5 (entlast))
(vl-cmdf "_.scale" aa5 "" "_none" aa2 aa7)
)))
(setq aa2 nil)
)
)
(setq aa4 (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object)))
aa1 (getvar "EXPLMODE"))
(setvar "EXPLMODE" 1)
(command "_.explode" aa5)
(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))))
(while (entnext aa5)
(setq aa5 (entnext aa5)
aa1 (entget aa5))
(if (/= aa3 1) ;Если вместо "(/= aa3 1)" "nil", то
; без сохранения масштаба штриховки и глоб.толщины полилиний
(if (= (cdr (assoc 0 aa1)) "HATCH")
(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 ""))
))(if (wcmatch (cdr (assoc 0 aa1)) "*POLYLINE")
(if (setq aa2 (assoc 43 aa1))
(vl-cmdf "_.pedit" "_m" aa5 "" "_w" (/ (cdr aa2) aa3) "")
))
))
)
))
(setvar "CMDECHO" 1)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
)
(princ "\nДля AutoCAD с 2006 версии")
)
(princ)
)