;|==================================================­==

^C^C^P(load "Fragm_Den");Fragm_Den

==================================================­==|;
(defun c:Fragm_Den (/ aa1 aa2 aa3 aa4 aa5 aa6 aa7 aa8)
(setq aa8 "IGAL"
aa1 (getpoint "\nSelect First Point of Regtangular Area:")
aa2 nil
aa6 nil)
(vl-load-com)
(if aa1
(if (setq aa2 (getcorner aa1 "\nSelect Second Point of Regtangular Area:"))(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))))
)
(setvar "CMDECHO" 0)
(command "_.undo" "_g"
"_.undo" "_m")
(if aa8 (if (tblsearch "Layer" aa8)(setvar "CLAYER" aa8)))
)
)(progn
(setq aa1 (getpoint "\nSelect Circle Center Point:"))
(setvar "CMDECHO" 0)
(command "_.undo" "_g"
"_.undo" "_m")
(if aa8 (if (tblsearch "Layer" aa8)(setvar "CLAYER" aa8)))
(princ "\nRadius of Circle:")
(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)
aa6 (* (cdr (assoc 40 (entget aa4))) 0.001)
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
(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 aa6
(setq aa8 (entlast))
(setq aa6 0.01
aa4 (entlast)
aa8 (ssadd))
)
(setvar "OSMODE" 0)
(setvar "LTSCALE" 0.0001)
(command "_.offset" aa6 (entlast)(getvar "EXTMAX") ""
"_.zoom" "_o" (setq aa5 (entlast) aa6 aa5) "")
(setvar "EXPLMODE" 1)
(while aa3
(setq aa3 (ssget "_F" aa1 '((-4 . ""))))
(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 '((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)
aa5 (length aa6))
(command "_.move" aa3 "" '(0 0 0) '(0 0 0)
"_.trim" aa4 "" "_f")
(repeat aa5
(command (nth (setq aa5 (1- aa5)) aa6))
)
(command "" ""
"_.erase" (ssget "_F" aa6
'((-4 . ""))
;;; '((-4 . ""))
)
aa5 aa8 "")
(setq 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 "\nSelect Destination of Element:"))
(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 "\nIgal Averbuh :")
(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))))
))
(command "_.undo" "_e")
(setvar "CMDECHO" 1)
(princ)
)
(c:Fragm_Den)

Advertisements