LISP. Фрагмент чертежа по прямоуг. или кругл. границе (Страница 5 из 5)

;|====================================================
Фрагмент чертежа по прямоуг.,кругл. или ломаной границе
(программа тестировалась на 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)
)