(mapcar ''((x) (vlax-put obj (strcat x "Effectivescalefactor") scl)) '("X" "Y"))
好主意和塔瓦的包围盒想法
这是测试
;rescale bubble test
(defun c:bubsc (/ bn scl ss blk bo scl s2 dp p i ip lo st isblk)
;hanhphuc 28.05.2018
(initget 7)
(and
(setq bn "test" ; <-- block name to modify
scl (getreal "\nSpecify scale factor : "))
(setq blk ((lambda (doc) (foreach x '(ActiveDocument Blocks) (setq doc (vlax-get doc x))))
(vlax-get-acad-object)
)
ss(ssget "X"
(list '(-4 . "<OR")'(-4 . "<AND")'(0 . "INSERT")(cons 2 bn)'(66 . 1)'(-4 . "AND>")
'(0 . "LINE")'(-4 . "OR>")'(410 . "Model")
)
)
)
(progn
(setq s2 (vl-remove-if-not ''((x) (= "LINE" (cdr (assoc 0 (entget x))))) (acet-ss-to-list ss))); grid line
(repeat (setq i (sslength ss))
(and (setq bo(vlax-ename->vla-object(ssname ss (setq i (1- i)))))
;(= (vla-get-Name bo) bn )
(setq isblk (= (vla-get-ObjectName bo) "AcDbBlockReference"))
(vlax-invoke bo 'scaleentity
(setq
ip ((lambda (obj / a b)
(vla-getboundingbox obj 'a 'b)
(apply 'mapcar
(cons ''((a b) (/ (+ a b) 2.0)) (mapcar 'vlax-safearray->list (list a b)))
)
)
bo
)
)
scl
) ;_ end of vlax-invoke
) ;_ end of and
(foreach x s2
(setq lo (vlax-ename->vla-object x)
dp (vl-sort (mapcar ''((x) (cons (distance ip (setq p (vlax-get lo x))) p)) '(StartPoint EndPoint))
''((a b) (< (car a) (car b)))
)
)
(if (and isblk
(equal (angle (setq st (cdar dp)) ip)(apply 'angle (reverse (mapcar 'cdr dp))) 0.1 )
)
(vlax-invoke bo 'move st
(polar st (angle st ip) (- (* scl (caar dp)) (caar dp)))
)
)
)
)
) ;_ end of progn
) ;_ end of and
(princ)
) ;_ end of defun
页:
1
[2]