大神大海大师代码程序-当屏幕缩得太小时显示出集中的位置
;;当屏幕缩得太小时显示出集中的位置__作者：tryhi大海(defun c:zoomcz(/ big boom box4 d enl i j mid4 p1 p2 pt pts s4 ttget xd xy yd)
(setq *En2Obj*vlax-ename->vla-object
*Obj2En*vlax-vla-object->ename
*2PI* (* PI 2)
*0.5PI* (/ PI 2)
*0.25PI*(/ PI 4)
;;常用VLA对象、集合
*ACAD*(vlax-get-acad-object)
*DOC* (vla-get-ActiveDocument *ACAD*)
*DOCS*(vla-get-Documents *ACAD*)
*MS* (vla-get-modelSpace *DOC*)
*PS* (vla-get-paperSpace *DOC*)
*BLKS*(vla-get-Blocks *DOC*)
*LAYS*(vla-get-Layers *DOC*)
*LTS* (vla-get-Linetypes *DOC*)
*STS* (vla-get-TextStyles *DOC*)
*GRPS*(vla-get-groups *DOC*)
*DIMS*(vla-get-DimStyles *DOC*)
*LOUTS* (vla-get-Layouts *DOC*)
*VPS* (vla-get-Viewports *DOC*)
*VS* (vla-get-Views *DOC*)
*DICS*(vla-get-Dictionaries *DOC*)
;;常用的几个外部接口对象
*FSO* (vlax-get-or-create-object "Scripting.FileSystemObject")
*WSH* (vlax-get-or-create-object "wscript.shell")
*SHELL* (vlax-get-or-create-object "Shell.Application")
*SCR* (vlax-get-or-create-object "ScriptControl")
*WBEM*(vlax-get-or-create-object "WbemScripting.SWbemLocator")
*ssnum* "~*[~`.-9]*"
)
;;;坐标范围选择，有点类似(ssget "c" p1 p2 filter),但本函数在屏幕外的也可选择
;;;测试 (tt (getpoint) (getpoint) '((0 . "insert")))
(defun ttget (p1 p2 filter / minX minY maxX maxY)
(setq minX (min (car p1) (car p2))
minY (min (cadr p1) (cadr p2))
maxX (max (car p1) (car p2))
maxY (max (cadr p1) (cadr p2))
)
(if filter
(ssget "x"
(append (list '(-4 . "<and")
'(-4 . ">=,>=,*")
(list 10 minX minY 0)
'(-4 . "<=,<=,*")
(list 10 maxX maxY 0)
)
(append filter '((-4 . "and>")))
)
)
(ssget "X"
(list '(-4 . "<and")
'(-4 . ">=,>=,*")
(list 10 minX minY 0)
'(-4 . "<=,<=,*")
(list 10 maxX maxY 0)
'(-4 . "and>")
)
)
)
)
(setq boom(try-zoom-get)
big(try-pt2-sc boom 1.05)
D(* 0.02(apply 'distance big))
xy(mapcar '- (cadr big)(car big))
xd(/ (car xy)8.)
yd(/(cadr xy)3.)
)
(setq i 0 j 0 pts nil)
(repeat 3
(repeat 8
(setq pt(try-Pt+XY (car big)(* i xd)(* j yd))
pts(cons pt pts)
i(1+ i)
)
)
(setq j(1+ j)i 0)
)
(setq box4(mapcar '(lambda(x)(list x(mapcar '+ x (list xd yd))))pts))
(apply 'try-zoom big)
(setq s4(mapcar '(lambda(x)(ttget (car x)(cadr x)nil))box4)
mid4(vl-remove nil (mapcar 'try-getbox-mid s4))
)
(setq enl(entlast))
(foreach x mid4
(setq p1(mapcar '+ x (list d d))
p2(mapcar '- x (list d d))
)
(try-make-rectang p1 p2)
)
(sssetfirst nil (try-ssend enl))
(princ)
)
;;;======================================
;;;===========以下为内裤部分=============
;;;======================================
(defun try-zoom-get ()(try-box-zoom))
(defun try-pt2-sc (pt2 n / mid p1 p2)
(setq ;pt2(try-pt2zy pt2)
p1(car pt2)
p2(cadr pt2)
mid(try-mid p1 p2)
)
(list (line-n% (list mid p1)n)(line-n% (list mid p2)n))
)
(defun try-Pt+XY (pt dx dy)(mapcar '+pt (list dx dy 0)))
(defun try-zoom (p1 p2 / pts)
(setq pts(try-box-zoom))
;(command "zoom" "w" "non" p1 "non" p2)
(vla-ZoomWindow *acad* (vlax-3d-point p1) (vlax-3d-point p2))
pts
)
(defun try-getbox-mid(en / b)(try-mid(car(setq b(try-GetBox en)))(cadr b)))
(defun try-make-rectang (pt1 pt2)
(try-make-Polyline(list pt1 (list(car pt1)(cadr pt2))pt2(list (car pt2)(cadr pt1)))T NIL)
)
(defun try-ssend(en / ss)
(if en(progn
(setq ss (ssadd))
(while (setq en(entnext en))(ssadd en ss))
ss
)
(ssget "x"))
)
(defun try-box-zoom(/ h c)
(setq c(getvar"viewctr")
h(*(getvar"viewsize")0.5)
h(list(*(apply'/(getvar"screensize"))h)h))
(mapcar'(lambda(x)(mapcar x c h))'(- +))
)
(defun try-mid(p1 p2)(mapcar '(lambda (a b) (* 0.5 (+ a b))) p1 p2))
(defun line-n% (pt2 n / ang d l p1 p2)
(setq
p1(car pt2)
p2(cadr pt2)
d(distance p1 p2)
L(* n d)
ang(angle p1 p2)
)
(polar p1 ang L)
)
(defun try-getbox (e / en i max1 min1 pt1 pt2 sn tx1 tx2 ty1 ty2 tye x1 x2 y1 y2 p1 p2)
(setq tye(type e))
(cond
((= 'VLA-object tye)
(vla-GetBoundingBox e 'p1 'p2);取得包容图元的最大点和最小点
(setq min1 (vlax-safearray->list p1));把变体数据转化为表
(setq max1 (vlax-safearray->list p2));把变体数据转化为表
(list min1 max1)
)
((= 'ENAME tye)
(try-GetBox (vlax-ename->vla-object e))
)
((or(= 'LIST tye)(= 'PICKSET tye))
(if (= 'PICKSET tye)(setq e (mapcar 'vlax-ename->vla-object (try-ss2EnList e))))
(if (= 'ENAME(type(car e)))(setq e(mapcar 'vlax-ename->vla-object e)))
(vla-getboundingbox (car e) 'pt1 'pt2);获取单个图元包盒
(setq
pt1(vlax-safearray->list pt1)
pt2 (vlax-safearray->list pt2)
tx1 (car pt1)
ty1 (cadr pt1)
tx2 (car pt2)
ty2 (cadr pt2)
)
(setq i 0)
(setq sn (length e))
(repeat (1- sn)
(setq en (nth (setq i (1+ i))e))
(vla-getboundingbox en 'pt1 'pt2);获取单个图元包盒
(setq
pt1(vlax-safearray->list pt1)
pt2 (vlax-safearray->list pt2)
x1 (car pt1)
y1 (cadr pt1)
x2 (car pt2)
y2 (cadr pt2))
(if (> tx1 x1)(setq tx1 x1))
(if (> ty1 y1)(setq ty1 y1))
(if (< tx2 x2)(setq tx2 x2))
(if (< ty2 y2)(setq ty2 y2))
)
(list (list tx1 ty1) (list tx2 ty2))
)
)
)
(defun try-make-Polyline (ptlst Close-tnil layer / a s1)
(if(or(= layer 0)(null layer))(setq layer (getvar "clayer")))
(entmakex
(append
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length ptlst))
(cons 70 (if Close-tnil 1 0))
(cons 8 layer)
(cons 38
(if (nth 2 (car ptlst))
(nth 2 (car ptlst))
0
)
)
)
(mapcar '(lambda (a) (cons 10 a)) ptlst)
)
)
)
(defun try-ss2EnList(ss / a en lst)
(setq a -1)
(if ss
(while
(setq en(ssname ss(setq a(1+ a))))
(setq lst(cons en lst))
)
)
(reverse lst)
)
(princ "\n当屏幕缩得过小时显示出集中的位置，命令zoomcz__作者：tryhi大海")(princ)
感谢 树櫴希德 分享程序!!!!! 大神跟大师就谈不上了 回帖是一种美德！感谢楼主的无私分享 谢谢 这个是干嘛用的，能说明下吗 感谢树櫴希德。我们这个版块人丁稀少。
页:
[1]