大神大海大师代码程序-当屏幕缩得太小时显示出集中的位置

树櫴希德 · 发表于 2017-9-29 21:41:37

;;当屏幕缩得太小时显示出集中的位置__作者：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)

;;当屏幕缩得太小时显示出集中的位置__作者：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)

yoyoho · 发表于 2017-9-30 08:28:19

感谢树櫴希德分享程序!!!!!

tryhi · 发表于 2017-9-30 11:54:58

大神跟大师就谈不上了

pengfei2010 · 发表于 2017-10-5 11:38:18

回帖是一种美德！感谢楼主的无私分享谢谢

664571221 · 发表于 2018-7-20 15:36:44

这个是干嘛用的，能说明下吗

wosyuwu · 发表于 2018-7-22 11:22:48

感谢树櫴希德。我们这个版块人丁稀少。

账号		自动登录	找回密码
密码			注册

大神大海大师代码程序-当屏幕缩得太小时显示出集中的位置

相关帖子