局部放大图

;;;** 局部放大图 By Gu_xl 2013.07.24 命令: ZoomMap **
;;
;; Copyright (c)2013 Gu_xl  
;; 版权所有  Gu_xl
;; 程序思路：
;; 1、首先确定放大范围的边界，可以用圆或多边形放大，计算出圆或多边形的顶点边界的点表PList，因XCLIP的边界为直线段，所以有圆弧的需要用直线来拟合一下。
;; 2、用(ssget "_CP" Plist)选中放大范围的实体，并将其制成无名块
;; 3、在原位置插入该无名块，并用XCLIP命令剪裁该无名块，剪裁边界就是PList
;; 4、根据放大倍数，放大该无名块，移动到相应位置！
;; 很多人在写放大程序时，都采用Trim对象来剪裁边界，Trim只能剪裁线性对象，块、文字、标注等都无法剪裁！遇到块还要炸开后再剪裁，不仅速度慢，边界往往剪裁不干净。利用剪裁块来做放大程序，优点是速度很快，剪裁边界外绝对不会有剪裁不净的内容！
;;作者保留本程序的一切权利，但你可以自由拷贝与复制、修改本程序用于非商业目的。
;;作者尽力将本程序做得完善，但不会因本软件的错失而造成的损失承担任何责任。
;;本程序仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊用途之适
;;应性, 以及商业销售所隐含作出的保证, 在此一概予以否认。  
;;  
(vl-load-com)
;;;*SysVarNL* 常用系统变量表
(setq *SysVarNL*
       (list 'AUNITS      'AUPREC      'ATTDIA    'ATTREQ
  'BLIPMODE    'DIMZIN      'CECOLOR    'CELTYPE
  'CLAYER      'CMDECHO     'TRIMMODE    'EXPERT
  'HIGHLIGHT   'LUNITS      'LUPREC    'EDGEMODE
  'OSMODE      'ORTHOMODE   'TEXTSTYLE   'PLINEWID 'PLINEGEN
  'FILEDIA     'PICKBOX     'QAFLAGS    'UCSAXISANG
  'CELTSCALE 'NOMUTT 'PEDITACCEPT 'Mirrtext 'limcheck
    )
) ;_ setq
;;;常量定义
(setq *Acad*    (vlax-get-acad-object)
      *AcDocument* (vla-get-activedocument *Acad*)
      *Model-Space* (vla-get-modelspace *AcDocument*)
      *Paper-Space* (vla-get-PaperSpace *AcDocument*)
      pi2    (* pi 0.5)
      pi4    (* pi 0.25)
      2pi    (* pi 2.)
      3pi2    (* 1.5 pi)
      3pi4   (+ pi2 pi4)
      5pi4   (+ pi pi4)
      7pi4 (+ 3pi2 pi4)
      pi6 (/ pi 6)
      2pi3 (/ pi 3 0.5)
      #ZJWS# 2
      *jd* 0.00001
      en2obj vlax-ename->vla-object
      obj2en vlax-vla-object->ename
      *Space* (vlax-get-property *AcDocument* (if (= 1 (getvar 'CVPORT)) 'PaperSpace 'ModelSpace))
)
;;;增加内置函数
(mapcar    'vl-arx-import
    '(ACAD_COLORDLG      ACAD_truecolordlg    ACAD_STRLSORT
   INITDIA      ACAD-POP-DBMOD    ACAD-PUSH-DBMOD
   STARTAPP      layoutlist Bpoly
  )
)
;;;*********************************************************************************
;;;*************函数 gxl-layer-restore.lsp  *************
;;(gxl-layer-Restore name delflag) 恢复图层状态,成功返回T，否则返回nil
(defun gxl-layer-Restore  (name delflag / lm rtn)
  (setq    lm
  (vla-GetInterfaceObject
    *ACAD*
    (strcat "AutoCAD.AcadLayerStateManager."
     (substr (getvar 'acadver) 1 2)
     )
    )
    )
  (vla-SetDatabase lm (vla-get-Database *ACDOCUMENT*))
  (setq    rtn
  (not
    (VL-CATCH-ALL-ERROR-P
      (VL-CATCH-ALL-APPLY 'vla-Restore (list lm name))
      )
    )
    )
  (if delflag
    (VL-CATCH-ALL-APPLY 'vla-delete (list lm name)))
  rtn
  )
;;;***************** 函数 gxl-layer-Restore*****************
;;;*************函数 gxl-restoreslayers.lsp  *************
;;;(gxl-restoreslayers) 恢复图层状态
(defun gxl-restoreslayers ()
  (gxl-LAYER-RESTORE "#GxlLayerSave" t)
  )
;;;***************** 函数 gxl-restoreslayers*****************
;;;*************函数 gxl-layer-save.lsp  *************
;;(gxl-layer-Save name Mask) 保存图层状态,成功返回T，否则返回nil
;|acLsAll All layer properties
acLsColor Color
acLsFrozen Frozen or thawed
acLsLineType Linetype
acLsLineWeight Lineweight  
acLsLocked Locked or unlocked  
acLsNewViewport New viewport layers frozen or thawed  
acLsNone None  
acLsOn On or off  
acLsPlot Plotting on or off  
acLsPlotStyle Plot style  
|;
(defun gxl-layer-Save  (name Mask / lm)
  (if (null Mask)
    (setq Mask aclsall))
  (setq    lm
  (vla-GetInterfaceObject
    *ACAD*
    (strcat "AutoCAD.AcadLayerStateManager."
     (substr (getvar 'acadver) 1 2)
     )
    )
    )
  (vla-SetDatabase lm (vla-get-Database *ACDOCUMENT*))
  (if (VL-CATCH-ALL-ERROR-P
    (VL-CATCH-ALL-APPLY 'vla-save (list lm name mask))
    )
    (progn
      (VL-CATCH-ALL-APPLY 'vla-delete (list lm name))
      (not
    (VL-CATCH-ALL-ERROR-P
   (VL-CATCH-ALL-APPLY 'vla-save (list lm name mask))
   )
    )
      )
    t
    )
  )
;;;***************** 函数 gxl-layer-Save*****************
;;;*************函数 gxl-storeslayers.lsp  *************
 ;_ 结束defun
;;;(gxl-storeslayers) 保存图层状态
(defun gxl-storeslayers (/ layers activelayer layer)
  (gxl-layer-Save "#GxlLayerSave" nil)
  )
;;;***************** 函数 gxl-storeslayers*****************
;;;*************函数 gxl-layer-unlockall.lsp  *************
;;;解锁所有图层 gxl-Layer-UnLockAll 语法 (gxl-Layer-UnLockAll)
(defun gxl-Layer-UnLockAll (/ n)
  (vlax-map-Collection
    (vla-get-layers
      (vla-get-ActiveDocument (vlax-get-acad-object))
    )
    '(lambda (n)
       (vla-put-lock n :vlax-false)
       ;(gxl-LOCKLAYERGRAY n) ;_ 锁定灰显
     )
  )
)
;;;***************** 函数 gxl-Layer-UnLockAll*****************
;;;*************函数 gxl-ge-pntinview.lsp  *************
;;(gxl-Ge-GetInsideScreenPts p1 p2) 将P1 p2 截取到当前屏幕显示范围,UcsFlag t,表示提供坐标为Ucs坐标
;;;**************************************************************************************************
;; | ----------------------------------------------------------------------------
;; | (gxl-GE-PntInView pt) 判断点是否在屏幕显示范围内 返回 T or nil
;; | ----------------------------------------------------------------------------
;; | Function : Check if point is in current viewport
;; | Auguments: 'pt'  - The point to be checked
;; | Return   : T or nil depending on 'pt' is in viewport or not
;; | Updated  : April 22, 1998
;; | e-mail   : rakesh.rao@4d-technologies.com  
;; | Web      : www.4d-technologies.com
;; | ----------------------------------------------------------------------------
;(gxl-GE-PntInView '(0 0 0))
(defun gxl-GE-PntInView(pt / vc Y_Len ssz X_Pix Y_Pix X_Len ll ur)
(setq
   vc    (getvar "VIEWCTR")
   Y_Len (getvar "VIEWSIZE")
   ssz   (getvar "SCREENSIZE")
   X_Pix (car ssz)
   Y_Pix (cadr ssz)
   X_Len (* (/ X_Pix Y_Pix) Y_Len)
   ll    (polar vc pi (* 0.5 X_Len))
   ur    (polar ll 0.0 X_Len)
   ll    (polar ll 3pi2 (* 0.5 Y_Len))
   ur    (polar ur pi2 (* 0.5 Y_Len))
)
(if (and
  (> (car pt) (car ll))
  (< (car pt) (car ur))
  (> (cadr pt) (cadr ll))
  (< (cadr pt) (cadr ur))
    )
    T
    nil
)
)
;;;***************** 函数 gxl-GE-PntInView*****************
;;;*************函数 gxl-ge-screenext.lsp  *************
;; | ---------------------------------------------------------------------------
;; | (gxl-ge-ScreenExt) 返回屏幕的左下角、右上角坐标
;; | ---------------------------------------------------------------------------
;; | Function : Returns the co-ordinates of the extents of the current view
;; |            window.
;; | Arguments: (none)
;; | Return   : (list LL UR)
;; |            LL - Lower Left corner
;; |            UR - Upper Right corner
;; | Update   : January 21, 2003
;; | e-mail   : rakesh.rao@4d-technologies.com  
;; | Web      : www.4d-technologies.com
;; | Comments : Available in VBA
;; | ---------------------------------------------------------------------------
;(gxl-ge-ScreenExt)
(defun gxl-ge-ScreenExt ( / VS VC SS 1Pixel dX dY LL UR )
(setq
    VS  (getvar "VIEWSIZE")
    VC  (trans (getvar "VIEWCTR") 1 0)
    SS  (getvar "SCREENSIZE")
    1Pixel    (/ VS (cadr SS))
    dX      (* 0.5 (car SS) 1Pixel)
    dY  (* 0.5 VS)
    LL      (list
    (- (car VC)  dX)
    (- (cadr VC) dY)
    0.0
      )
    UR  (list
    (+ (car VC)  dX)
    (+ (cadr VC) dY)
    0.0
      )
)
(list LL UR)
)
;;;***************** 函数 gxl-ge-ScreenExt*****************
;;;*************函数 gxl-ge-extents.lsp  *************
;; | ---------------------------------------------------------------------------
;; | (gxl-GE-Extents plist) 返回点表的包围框坐标 '(左下角点 右上角点)
;; | ---------------------------------------------------------------------------
;; | Function : Return the x,y and z extents of a list of points
;; | Argument : 'vlist' - List of points
;; | Returns  : A list of p1 and p2, where p1 is lower left corner point (x,y,z)
;; |            and p2 is the upper right corner point (x,y,z).
;; | Update   : March 6, 1998
;; | e-mail   : rakesh.rao@4d-technologies.com
;; | Web      : www.4d-technologies.com
;; | ---------------------------------------------------------------------------
; Return the Extents of a list of points.
(defun gxl-GE-Extents(vlist / MinX MaxX MinY MaxY MinZ MaxZ tmp pt )
(setq
    MinX 1E20 MinY 1E20 MinZ 1E20
    MaxX -1E20 MaxY -1E20 MaxZ -1E20
)
(foreach pt vlist
    (if (< (setq tmp (car pt)) MinX)
        (setq MinX tmp)
    )
    (if (< (setq tmp (cadr pt)) MinY)
  (setq MinY tmp)
    )
    (if (> (setq tmp (car pt)) MaxX)
        (setq MaxX tmp)
    )
    (if (> (setq tmp (cadr pt)) MaxY)
  (setq MaxY tmp)
    )
    (if (and (setq tmp (caddr pt)) (< tmp MinZ))
  (setq MinZ tmp)
    )
    (if (and (setq tmp (caddr pt)) (> tmp MaxZ))
  (setq MaxZ tmp)
    )
)
(if (= MinZ 1E20) (setq MinZ 0.0))
(if (= MaxZ -1E20) (setq MaxZ 0.0))
(list (list MinX MinY MinZ) (list MaxX MaxY MaxZ))
)
;;;***************** 函数 gxl-GE-Extents*****************
;;;*************函数 gxl-ge-zoom2lst.lsp  *************
;; | ----------------------------------------------------------------------------
;; | (gxl-GE-Zoom2Lst plist) 点表范围显示
;; | ----------------------------------------------------------------------------
;; | Function : Zoom to the extents of a list of points
;; | Arguments:
;; |           'vlist' - List of points
;; | Action   : Performs a Zoom Window operation using the bottom left and top
;; |            right corners of a list of points
;; | Updated  : November 2, 1998
;; | e-mail   : rakesh.rao@4d-technologies.com
;; | Web      : www.4d-technologies.com
;; | ----------------------------------------------------------------------------
;;;(gxl-GE-Zoom2Lst (gxl-getbox (car (entsel))))
(defun gxl-GE-Zoom2Lst( vlist / bl tr Lst OS )
(setq
    Lst (gxl-GE-Extents vlist)
    bl (car Lst)
    tr (cadr Lst)
)
(if (not (and (gxl-GE-PntInView bl) (gxl-GE-PntInView tr)))
(progn
    (setq OS (getvar "OSMODE"))
    (setvar "OSMODE" 0)
    (command
  "._Zoom" "_Window" bl tr
  "._Zoom" "0.95x"
    )
    (setvar "OSMODE" OS)
))
)
;;;***************** 函数 gxl-GE-Zoom2Lst*****************
;;;*************函数 gxl-ge-zoominpt.lsp  *************
;; | ----------------------------------------------------------------------------
;; | （gxl-GE-ZoomInPt pt) 将点显示到屏幕范围内
;; | ----------------------------------------------------------------------------
;; | Function : Zooms current extents to include a pt if it lies outside the
;; |            screen
;; | Argument : [pt] - point of interest
;; | Return   : None
;; | Updated  : December 18, 1998
;; | e-mail   : rakesh.rao@4d-technologies.com
;; | Web      : www.4d-technologies.com
;; | ----------------------------------------------------------------------------
(defun gxl-GE-ZoomInPt( pt / ptlst )
(if (not (gxl-GE-PntInView pt))
(progn
    (setq ptlst (cons pt (gxl-ge-ScreenExt)))
    (gxl-GE-Zoom2Lst ptlst)
))
)
;;;***************** 函数 gxl-GE-ZoomInPt*****************
;;;*************函数 gxl-ge-grdrawcross.lsp  *************
;;;(gxl-Ge-GRDrawCross pt size rotation color B) 画十字交叉 参数：pt 点 size 十字大小 rotation 十字旋转角 color 颜色 B T size为绝对大小 nil 屏幕相对大小
;;;(gxl-Ge-GRDrawCross (getpoint) 5 pi4 1 t)
(defun gxl-Ge-GRDrawCross (pt size rotation color B / pts p1 p2 p3 p4 d)
  (gxl-GE-ZoomInPt pt)
  (if (not B)
    (progn
      (setq d (apply '- (mapcar 'cadr (reverse(gxl-GE-SCREENEXT)))))
      (setq size (* (/ size 100.0) d))
      )
    )
  (setq p1 (polar pt rotation (* size 0.5))
    p2 (polar p1 (+ pi rotation) size)
    p3 (polar pt (+ pi2 rotation) (* size 0.5))
    p4 (polar pt (+ 3pi2 rotation) (* size 0.5))
    )
  (IF (MINUSP COLOR)
    (PROGN
      (SETQ COLOR (ABS COLOR))
  (grdraw p1 p2 color 1 )
   (grdraw p3 p4 color 1)
  )
    (PROGN
  (grdraw p1 p2 color)
   (grdraw p3 p4 color)
  )
    )
  )
;;;***************** 函数 gxl-Ge-GRDrawCross*****************
;;;*************函数 gxl-getspace.lsp  *************
;;;得到空间变量
(defun gxl-GetSpace ()
  (setq *Space* (vlax-get-property *AcDocument* (if (= 1 (getvar 'CVPORT)) 'PaperSpace 'ModelSpace)))
  )
;;;***************** 函数 gxl-GetSpace*****************
;;;*************函数 gxl-ax：addcircle.lsp  *************
 ;_ 结束defun
;;;===================================================================
;;; (gxl-AX:AddCircle obj pt R) 制造园实体
(defun gxl-AX:AddCircle (obj pt R)
  (vla-AddCircle
    (if obj obj (gxl-GETSPACE))
    (vlax-3d-point pt)
    R
  ) ;_ 结束vla-Addline
)
;;;***************** 函数 gxl-AX:AddCircle*****************
;;;*************函数 gxl-sel-entnextall.lsp  *************
;;;gxl-Sel-EntNextAll en 返回 en 之后的所有物体选择集，无则返回 nil,en为nil返回图形全部图元
(defun gxl-Sel-EntNextAll (ent / ss)
  (if (not ent)
    (progn
      (setq ent (entnext))
      (if ent
        (setq ss (ssadd ent))
        (setq ss (ssadd))
        )
      )
    (setq ss (ssadd))
    )
  (while (setq ent (entnext ent))
    (if (not (member (cdr (assoc 0 (entget ent)))
                     '("ATTRIB" "VERTEX" "SEQEND")
                     )
             )
      (ssadd ent ss)
      )
    )
  (if (= 0 (sslength ss))
    nil
    ss
    )
  )
;;;***************** 函数 gxl-Sel-EntNextAll*****************
;;;*************函数 gxl-command.lsp  *************
;;自定义一个gxl-Command 函数，在lisp中自定义运行任何CAD的command命令，返回选择自，无需考虑cad命令所需参数，
;;;参数 cad命令字符串，例如：(gxl-Command "line")，返回line命令所画的全部直线选择集
(defun gxl-Command (cmd / EN cmdecho)
  (setq cmdecho (getvar "cmdecho"))
  (setvar "cmdecho" 1)
  (SETQ EN (ENTLAST))
  (vl-cmdf cmd)
  (while (= 1 (getvar "cmdactive"))
  (vl-cmdf pause) ;_ (vl-cmdf "\\")
    )
  (setvar "cmdecho" cmdecho)
  (gxl-SEL-ENTNEXTALL en)
  )
;;;***************** 函数 gxl-Command*****************
;;;*************函数 gxl-ch_ent.lsp  *************
;;;==================================================================
;;;(gxl-CH_Ent ent i pt) 用新值pt更新图元ent索引i对应的值
;;;==================================================================
(defun gxl-CH_Ent (ent i pt / en)
  (if (assoc i (setq en (entget ent)))
    (setq en (subst (cons i pt) (assoc i en) en))
    (setq en (append en (list (cons i pt))))
    )
    (entmod en)
  (entupd ent)
  )
;;;***************** 函数 gxl-CH_Ent*****************
;;;*************函数 gxl-midpoint.lsp  *************
;;;==================================================================
;;;gxl-MidPoint 表操作函数,计算两点的中点
;;;计算两点的中点
;;;==================================================================
(defun gxl-MidPoint (p1 p2)
  (mapcar '(lambda (x) (* x 0.5)) (mapcar '+ p1 p2))
  )
;;;***************** 函数 gxl-MidPoint*****************
;;;*************函数 gxl-massoc.lsp  *************
;;;==================================================================
;;;gxl-massoc 返回包含每一出现在列表中的指定键的cdr(点对的后部分)的列表。
;|功能
返回包含每一出现在列表中的指定键的cdr(点对的后部分)的列表。
参数
一个整数和一个图元定义列表
示例
(gxl-massoc 10 (entget (car (entsel))))  
注意
该函数特别适合用于找到细多义线上的所有顶点。
|;
;;;==================================================================
(defun gxl-massoc (key alist)
  (if (= 'ename (type alist))
    (setq alist (entget alist))
  )
  (mapcar 'cdr
   (vl-remove-if-not '(lambda (x) (equal key (car x))) alist)
  )
)
;;;***************** 函数 gxl-massoc*****************
;;;*************函数 gxl-listp.lsp  *************
;;;(gxl-listp lst) 判断表是否为真正的表,非nil、非点对表
;;;(gxl-listp nil) nil (gxl-listp '(1 . 2)) (gxl-listp '(1  2))
(defun gxl-listp (lst)
  (and (vl-consp lst)
       (vl-list-length lst)
       )
  )
;;;***************** 函数 gxl-listp*****************
;;;*************函数 gxl-dxf.lsp  *************
;;;==================================================================
;;;(gxl-dxf ent i )取出图元索引i对应的值
;;;==================================================================
(defun gxl-dxf    (ent i)
  (if (= (type ent) 'ename)
    (setq ent (entget ent '("*")))
    )
  (cond    ((atom i)
  (cdr (assoc i ent))
  )
    ((gxl-listp i)
  (mapcar '(lambda (x) (cdr (assoc x ent))) i)
  )
    )
  )
;;;***************** 函数 gxl-dxf*****************
;;;*************函数 gxl-mat-mxm.lsp  *************
;; Matrix x Matrix - Lee Mac 2010
;; Args: m,n - nxn matrices
;;;(gxl-Mat-MxM  m v ) 矩阵*矩阵
;|(defun gxl-Mat-MxM ( m n )
  ( (lambda ( a ) (mapcar '(lambda ( r ) (gxl-Mat-MXV a r)) m)) (gxl-Mat-trp n))
)|;
;(gxl-Mat-MxM '((3 5 2 1) (0 3 0 4) (1 1 1 1)(1 -1 -3 2)) '((3 5 2 1) (0 3 0 4) (1 1 1 1)(1 -1 -3 2)))
;(gxl-Mat-Compose '((3 5 2 1) (0 3 0 4) (1 1 1 1)(1 -1 -3 2)) '((3 5 2 1) (0 3 0 4) (1 1 1 1)(1 -1 -3 2)))
;;(gxl-Mat-MxM '((3 5 2 1) (0 3 0 4) ) '((3 5 ) ( 0 4) ( 1 1)(1 -1 -))) (gxl-Mat-MxM '((3 5 ) ( 0 4) ( 1 1)(1 -1 -)) '((3 5 2 1) (0 3 0 4) ))
(defun gxl-Mat-MxM (m n)
  (
   (lambda (a)
     (mapcar '(lambda (r)
                (mapcar '(lambda (s) (apply '+ (mapcar '* s r))) a)
                )
             m
             )
     )
    (apply 'mapcar (cons 'list n))
    )
  )
;;;***************** 函数 gxl-Mat-MxM*****************
;;;*************函数 gxl-mat-mxmxm.lsp  *************
;;(gxl-Mat-MxMxM MatLst) 矩阵连续相乘，MatLst变换顺序自右向左
(defun gxl-Mat-MxMxM (MatLst)
  (if (car MatLst)
    (if (cdr MatLst)
      (gxl-Mat-MxM
        (car MatLst)
        (gxl-Mat-MxMxM (cdr MatLst))
        )
      (car MatLst)
      )
    )
  )
;;;***************** 函数 gxl-Mat-MxMxM*****************
;;;*************函数 gxl-mat-translation.lsp  *************
;;;-----------------------------------------------------------;;
;;; (gxl-Mat-Translation v) 平移变换矩阵方式1       ;;
;;; 参数:            ;;
;;; v - 位移矢量                                              ;;
;;;-----------------------------------------------------------;;
;;;---------------=={ Translate by Matrix }==-----------------;;
;;;                                                           ;;
;;; Translation Matrix                                        ;;
;;;-----------------------------------------------------------;;
;;; Author: highflybird, Copyright ? 2012                     ;;
;;;-----------------------------------------------------------;;
;;; Arguments:                                                ;;
;;; v  - Displacement vector by which to translate            ;;
;;;-----------------------------------------------------------;;
(defun gxl-Mat-Translation ( v )
  (list
    (list 1. 0. 0. (car v))
    (list 0. 1. 0. (cadr v))
    (list 0. 0. 1. (caddr v))
    (list 0. 0. 0. 1.)
  )
)
;;;***************** 函数 gxl-Mat-Translation*****************
;;;*************函数 gxl-mat-rotatez.lsp  *************
;;; gxl-Mat-RotateZ 绕Z軸旋转矩阵
(defun gxl-Mat-RotateZ (an)
  (list (list (cos an) (- (sin an)) 0. 0.)
        (list (sin an) (cos an) 0. 0.)
        '(0. 0. 1. 0.)
        '(0. 0. 0. 1.)
        )
  )
;;;***************** 函数 gxl-Mat-RotateZ*****************
;;;*************函数 gxl-mat-scale.lsp  *************
;;; gxl-Mat-Scale 缩放矩阵
;;;(gxl-Mat-Scale  2)
(defun gxl-Mat-Scale (s)
  (cond
    ((and (= (type s) 'list) (= (length s) 3))
     ;;X Y Z 不等比缩放，CAD不接受非
     (list (list (car s) 0. 0. 0.)                          ;等比矩阵
           (list 0. (cadr s) 0. 0.)
           (list 0. 0. (caddr s) 0.)
           '(0. 0. 0. 1.)
           )
     )
    ((numberp s)                                            ;等比缩放
     (list (list s 0. 0. 0.)
           (list 0. s 0. 0.)
           (list 0. 0. s 0.)
           '(0. 0. 0. 1.)
           )
     )
    )
  )
;;;***************** 函数 gxl-Mat-Scale*****************
;;;*************函数 gxl-mat-transform1.lsp  *************
;;(gxl-Mat-TransForm1 scale rotate move) 计算平移、旋转、缩放矩阵
;;参数 scale = 缩放比例或XYZ缩放比例表'(sx sy sz)
;;     rotate = 旋转角
;;     move = 平移参数表 '(dx dy dz)
(defun gxl-Mat-TransForm1 (scale rotate move)
  (gxl-Mat-MxMxM
    (list (gxl-Mat-Translation move)
   (gxl-Mat-RotateZ rotate)
   (gxl-Mat-Scale scale)
    )
  )
)
;;;***************** 函数 gxl-Mat-TransForm1*****************
;;;*************函数 gxl-pt-》3d.lsp  *************
;;; (gxl-pt->3d p) 无条件转换为3维点，
(defun gxl-pt->3d (p)
  (cond ((= 'LIST (type p))
  (if (= 1 (length p))
    (list (if (= 'REAL (type (car p))) (car p) (atof (itoa (car p))))  0.0 0.0)
    (if (= 2 (length p))
    (list (if (= 'REAL (type (car p))) (car p) (atof (itoa (car p))))
   (if (= 'REAL (type (cadr p))) (cadr p) (atof (itoa (cadr p))))
   0.0
   )
      (list (if (= 'REAL (type (car p))) (car p) (atof (itoa (car p))))
   (if (= 'REAL (type (cadr p))) (cadr p) (atof (itoa (cadr p))))
   (if (= 'REAL (type (caddr p))) (caddr p) (atof (itoa (caddr p))))
   )
      )
    )
  )
    ((= 'REAL (type p))
  (list p 0.0 0.0)
  )
    ((= 'INT (type p))
  (list (atof (itoa p)) 0.0 0.0)
  )
    (t nil)
    )
  )
;;;***************** 函数 gxl-pt->3d*****************
;;;*************函数 gxl-mat-mxv.lsp  *************
;; Matrix x Vector - Lee Mac 2010
;; Args: m - nxn matrix, v - vector in R^n
;;;(gxl-Mat-MXV  m v ) 矩阵*向量 ,即坐标转换 4X4矩阵 * 向量
;;;(gxl-Mat-MXV '((1.57897 -1.84131 0.0 1144.8) (1.22754 2.36845 0.0 312.421) (0.0 0.0 2.0 0.0) (0.0 0.0 0.0 1.0)) (append (getpoint) '(1)))
;;(gxl-Mat-MXV (gxl-Mat-TRP (nth 2 (nentsel))) '(0 0 0 1))
(defun gxl-Mat-MXV (m v)
  (mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m)
)
;;;***************** 函数 gxl-Mat-MXV*****************
;;;*************函数 gxl-mat-mxp.lsp  *************
;;;(gxl-Mat-MxP  m p ) 4X4矩阵*点 得到转换后的点
;;(gxl-Mat-MxP '((1.57897 -1.84131 0.0 1144.8) (1.22754 2.36845 0.0 312.421) (0.0 0.0 2.0 0.0) (0.0 0.0 0.0 1.0)) (getpoint))
(defun gxl-Mat-MxP (m p / v)
  (setq v (append (gxl-pt->3d p) '(1.0)))
  (reverse (cdr (reverse (gxl-Mat-MxV m v))))
)
;;;***************** 函数 gxl-Mat-MxP*****************
;;;*************函数 gxl-xclipboundary.lsp  *************
;;(gxl-XClipBoundary ename) 计算XClip的包围点,某些情况不行
;;(gxl-ge-grdrawbox (gxl-XClipBoundary (car(entsel))) 1)
;; http://www.theswamp.org/index.php?topic=39201.0 LeeMac
;;(gxl-XClipBoundary ename) 计算XClip的包围点
;;;(gxl-ge-grdrawlines (gxl-XClipBoundary (car(entsel))) 3 t)
(defun gxl-XClipBoundary
       (ENAME / ISXCLIP EL PL DXF40 SCALE ROTATE MOVE M0 M1 n)
  (defun IsXClip (ename / xdict)
    (if
      (setq xdict (cdr (assoc 360 (entget ename))))
       (IsXClip xdict)
       (if
         (and
           (eq "SPATIAL_FILTER"
               (cdr (assoc 0 (setq ename (entget ename))))
               )
           (eq 1 (cdr (assoc 71 ename)))
           )
          ename
          )
       )
    )
  (if (setq el (IsXClip ename))
    (progn
      (setq pl     (gxl-massoc 10 el) ;_ 顶点坐标
            n (gxl-dxf el 70)
            dxf40  (gxl-massoc 40 el) ;_ 矩阵数据表
            scale  (list (gxl-dxf ename 41)  
                         (gxl-dxf ename 42)
                         (gxl-dxf ename 43)
                         ) ;_ 缩放比例
            rotate (gxl-dxf ename 50) ;_ 旋转角度
            move   (gxl-dxf ename 10) ;_ 平移参数
            )
      (if (= 1 (gxl-dxf el 72)) (setq dxf40 (cdr dxf40)))
      (setq m0
             (list
               (list (nth 0 dxf40)
                     (nth 1 dxf40)
                     (nth 2 dxf40)
                     (nth 3 dxf40)
                     )
               (list (nth 4 dxf40)
                     (nth 5 dxf40)
                     (nth 6 dxf40)
                     (nth 7 dxf40)
                     )
               (list (nth 8 dxf40)
                     (nth 9 dxf40)
                     (nth 10 dxf40)
                     (nth 11 dxf40)
                     )
               '(0 0 0 1)
               )
            ) ;_ 顶点的变换矩阵
      (if (= 2 n)
        (progn
          (list (car pl)
                (list (caar pl) (cadadr pl) (caddar pl))
                (cadr pl)
                (list (caadr pl) (cadar pl) (caddar pl))
                )
          )
        pl
        )
      (setq m1 (gxl-Mat-TransForm1 scale rotate move)) ;_ 图块的变换矩阵 Def -> Ref
      (setq pl (mapcar '(lambda (x) (gxl-mat-mxp (gxl-MAT-MXM m1 m0) x))  pl)) ;_ 点的矩阵变换
      )
    )
  )
;;;***************** 函数 gxl-XClipBoundary*****************
;;;*************函数 gxl-getbox.lsp  *************
;;;*******************************************************************************************************
;;By Longxin 明经通道 2005.06
;;gxl-getbox 取得实体外矩形框
;;例：(gxl-getbox 图元名)
;;返回：((x1 y1 z1)_min (x2 y2 z2)_max)
;;(gxl-Ge-GRDrawBox (gxl-getbox (car (entsel)) ) 1)
(defun gxl-getbox (E1 / OBJ MINPOINT MAXPOINT P1 P2 P3 P4 D DD PL D1 D3 D2 D4 name ll)
  (if (= 'ENAME (type e1))
    (setq obj (vlax-ename->vla-object e1))                  ;转换图元名
    (setq obj e1
          e1  (vlax-vla-object->ename e1)
          )
    )
  (if (not
    (VL-CATCH-ALL-ERROR-P
   (VL-CATCH-ALL-APPLY
     'vla-GetBoundingBox
     (list obj 'minpoint 'maxpoint)
   )
    )
      )
    (progn
        ;取得包容图元的最大点和最小点
      (setq minpoint (vlax-safearray->list minpoint))
        ;把变体数据转化为表
      (setq maxpoint (vlax-safearray->list maxpoint))
        ;把变体数据转化为表
      ;;(command "box" minpoint maxpoint 2)
      (cond
        ((= (vla-get-objectname obj) "AcDbSpline")
   (setq    p1 minpoint
  p2 (list (car minpoint) (cadr maxpoint) (caddr minpoint))
  p3 maxpoint
  p4 (list (car maxpoint) (cadr minpoint) (caddr minpoint))
   )
   (setq    d  (/ (distance p1 p2) 250)
  dd (- d)
  pl nil
   )
   (repeat 251
     (setq pl (cons (polar p1 pi2 (setq dd (+ dd d))) pl))
   )
   (setq    d1
   (car (vl-sort
      (mapcar
     '(lambda (x)
        (distance x
           (vlax-curve-getclosestpointto obj x)
        )
      )
     pl
      )
      '(lambda (a b) (< a b))
        )
   )
   )
   (setq    dd (- d)
  pl nil
   )
   (repeat 251
     (setq pl (cons (polar p4 pi2 (setq dd (+ dd d))) pl))
   )
   (setq    d3
   (car (vl-sort
      (mapcar
     '(lambda (x)
        (distance x
           (vlax-curve-getclosestpointto obj x)
        )
      )
     pl
      )
      '(lambda (a b) (< a b))
        )
   )
   )
   (setq    d  (/ (distance p2 p3) 250)
  dd (- d)
  pl nil
   )
   (repeat 251
     (setq pl (cons (polar p2 0 (setq dd (+ dd d))) pl))
   )
   (setq    d2
   (car (vl-sort
      (mapcar
     '(lambda (x)
        (distance x
           (vlax-curve-getclosestpointto obj x)
        )
      )
     pl
      )
      '(lambda (a b) (< a b))
        )
   )
   )
   (setq    dd (- d)
  pl nil
   )
   (repeat 251
     (setq pl (cons (polar p1 0 (setq dd (+ dd d))) pl))
   )
   (setq    d4
   (car (vl-sort
      (mapcar
     '(lambda (x)
        (distance x
           (vlax-curve-getclosestpointto obj x)
        )
      )
     pl
      )
      '(lambda (a b) (< a b))
        )
   )
   )
   (list    (list (+ (car minpoint) d1)
        (+ (cadr minpoint) d4)
        (caddr minpoint)
  )
  (list (- (car maxpoint) d3)
        (- (cadr maxpoint) d2)
        (caddr minpoint)
  )
   )
    )
        ((setq ll (gxl-XClipBoundary e1)) ;_ XClip盒子
   (list    (apply 'mapcar (cons 'min ll))
  (apply 'mapcar (cons 'max ll))
   )
    )
        (t
    (list minpoint maxpoint)
         )
      )
    )
    (list (getvar 'extmin) (getvar 'extmax))
  )
)
;;;***************** 函数 gxl-getbox*****************
;;;*************函数 gxl-sel-entsel.lsp  *************
;;;(gxl-Sel-ENTSEL 提示 过滤表),相当于EntSel,醒目显示
;;USAGE:(gxl-Sel-ENTSEL "\n请选Polyline物件: " '((0 . "*Polyline")))
(defun gxl-Sel-ENTSEL (STR FILTER / PT MIND OLDPT SS SS_NAME FLAG)
  (if (/= (type STR) 'STR)
    (progn (princ "\n变量类型不对，STR应为字符串。\n")
    nil
    ) ;_ progn
    (progn
      (if (and FILTER (/= (type FILTER) 'list))
    (progn (princ "\n变量类型不对，FILTER应为表。\n")
        nil
    ) ;_ progn
    (progn
   (princ STR)
   (setq PT (grread t 5 2))
   (setq mind (* (getvar "viewsize") 0.01))
   (if (not oldpt)
     (setq oldpt (cadr PT))
   )
   (while (not flag) ;_(and (/= 3 (car PT))(not (and (= (car pt) 2) (= 13 (cadr pt)))))
     (cond
       ((and (= 5 (car PT))
      (> (distance (cadr PT) oldpt) mind)
        )
        (setq PT    (cadr PT)
       oldpt pt
        )
        (if FILTER
   (setq SS (ssget PT FILTER))
   (setq SS (ssget PT))
        ) ;_ if
        (if (and    ss
      (equal (ssname SS 0) SS_NAME)
     )
   ()
   (progn
     (if SS_NAME
       (redraw SS_NAME 4)
     ) ;_ if
     (setq SS_NAME NIL)
     (if SS
       (progn (setq SS_NAME (ssname SS 0))
       (redraw SS_NAME 3)
       )
     ) ;_ if
   )
        )
       ) ;_
       ((or (= 3 (car PT)) (and (= (car pt) 2) (= 13 (cadr pt))))
        (setq flag t)
       )
     ) ;_ cond
     (setq mind (* (getvar "viewsize") 0.005))
     (if    (not flag)
       (setq PT (grread t 5 2))
     )
     (if    (= 25 (car pt))
       (setq flag t
      pt nil
       )
     )
   ) ;_ while
   (if pt
     (progn
       (setq PT (cadr PT))
       (if (= 13 pt)
  (setq pt (cadr (grread t)))
       )
       (if FILTER
  (setq SS (ssget PT FILTER))
  (setq SS (ssget PT))
       )
       (if SS_NAME
  (redraw SS_NAME 4)
       ) ;_ if
       (setq SS_NAME NIL)
       (if SS
  (progn (setq SS_NAME (ssname SS 0)) (list SS_NAME PT))
  SS_NAME
       ) ;_ if
     )
     (progn
       (if SS_NAME
  (redraw SS_NAME 4)
       )
     )
   )
    ) ;_ progn
      ) ;_ if
    ) ;_ progn
  ) ;_ if
)
;;;***************** 函数 gxl-Sel-ENTSEL*****************
;;;*************函数 gxl-catchapply.lsp  *************
;;;(gxl-CatchApply fun args) 重定义 VL-CATCH-ALL-APPLY ,如函数错误返回nil
;;;(gxl-CatchApply vla-offset (list (vlax-ename->vla-object (car(entsel))) 10))  
(defun gxl-CatchApply ( fun args / result )
  ;; ?Lee Mac 2010
  (if
    (not
      (vl-catch-all-error-p
        (setq result
          (vl-catch-all-apply (if (= 'SYM (type fun)) fun (function fun)) args)
        )
      )
    )
    result
  )
)
;;;***************** 函数 gxl-CatchApply*****************
;;;*************函数 gxl-get_poly_ptlist.lsp  *************
;;;==================================================================
;;;gxl-get_poly_ptList 返回多义线顶点点列表不含圆弧段内容，闭合多义线点表不含闭合点坐标
;;;(gxl-get_poly_ptList (car (entsel)))
;;;==================================================================
(defun gxl-get_poly_ptList (e / _pl n k objname)
  (setq objname
  (cond
    ((gxl-CATCHAPPLY vla-get-ObjectName (list e)))
    ((gxl-CATCHAPPLY gxl-dxf (list e 0)))
    )
    )
  (cond    ((or
    (= "AcDbCircle" objname)
    (= "CIRCLE" objname)
    )
  (list (vlax-curve-getPointAtParam e 0)
        (vlax-curve-getPointAtParam e pi2)
        (vlax-curve-getPointAtParam e pi)
        (vlax-curve-getPointAtParam e 3pi2)
  )
    )
    ((or
    (= "AcDbArc" objname)
    (= "ARC" objname)
    )
  (list (vlax-curve-getStartPoint e)
        (vlax-curve-getendPoint e)
  )
    )
    (t
  (setq n (1+ (fix (vlax-curve-getEndParam e)))
        k -1
  )
  (if (vlax-curve-isClosed e)
    (setq n (1- n))
  )
  (repeat n
    (setq k (1+ k))
    (if (vlax-curve-getSecondDeriv e k)
    (setq _pl (append _pl (list (vlax-curve-getPointAtParam e k))))
      )
  )
    )
  )
)
;;;***************** 函数 gxl-get_poly_ptList*****************
;;;*************函数 gxl-get_poly_ptlist3.lsp  *************
 ;_ 结束defun
;;;gxl-get_poly_ptList3 返回多义线顶点点列表,有圆弧则用一定角度分割圆弧，闭合多义线点表不含闭合点坐标
;;;(gxl-AX:ADDLWPOLYLINE *MODEL-SPACE* (gxl-get_poly_ptList3 (car (entsel)) 0.5))
;;(gxl-Ge-GRDrawLines (gxl-get_poly_ptList3 (car (entsel)) 1) 1 t)
(defun gxl-get_poly_ptList3 (ENT FGX    /      OBJNAME      VERTEXSNUM
     N    PT     PLIST  SECDEV BUGLE
     BJ    D1     D2     D      K
     D0    PARAM
    )
  (setq objname
  (cond
    ((gxl-CATCHAPPLY vla-get-ObjectName (list ent)))
    ((gxl-CATCHAPPLY gxl-dxf (list ent 0)))
    )
    )
  (setq    vertexsNum
  (fix (vlax-curve-getEndParam ent))
    n 0
  ) ;_ 结束setq
  (cond    ((or
    (= "AcDbCircle" objname)
    (= "CIRCLE" objname)
    )
  (if (equal fgx 0 1e-6)
    (setq fgx pi2)
  )
  (setq vertexsNum
  (fix (/ 2pi fgx))
        n 0
  )
  (repeat vertexsNum
    (setq pt (vlax-curve-getPointAtParam ent (* n fgx)))
    (setq plist (cons pt plist)
   n     (1+ n)
    )
  )
  (reverse plist)
    )
    (t
  (if (or
        (= "AcDb2dPolyline" objName)
        (= "POLYLINE" objName)
        )
    (progn
      (repeat vertexsNum
        (setq pt (vlax-curve-getPointAtParam ent n))
        (setq plist (cons pt plist))
        (setq pt (vlax-curve-getPointAtParam ent (+ 0.25 n)))
        (setq plist (cons pt plist))
        (setq pt (vlax-curve-getPointAtParam ent (+ 0.5 n)))
        (setq plist (cons pt plist))
        (setq pt (vlax-curve-getPointAtParam ent (+ 0.75 n)))
        (setq plist (cons pt plist))
        (setq n (1+ n))
      )
      (if (not (vlax-curve-isClosed ent))
        (setq plist (cons (vlax-curve-getEndPoint ent) plist))
      ) ;_ 结束if
      (reverse plist)
    )
    (if (equal fgx 0 1e-6)
      (gxl-GET_POLY_PTLIST ent)
      (progn
        (if (= 'ename (type ent)) (setq ent (vlax-ename->vla-object ent)))
        (repeat vertexsNum
   (if (setq secdev (vlax-curve-getSecondDeriv ent n))
     (progn
   (setq pt    (vlax-curve-getPointAtParam ent n)
         bugle (vla-GetBulge ent n)
   ) ;_ 结束setq
   (setq plist (cons pt plist))
   (if (/= bugle 0.0)
     (progn
       (setq bj (* (atan (abs bugle)) 4))
       (setq d1  (vlax-curve-getdistAtParam ent n)
      d2  (vlax-curve-getdistAtParam ent (1+ n))
      d  (- d2 d1)
      k  (fix (/ bj fgx))
      d0  (/ 1.0 (1+ k))
      param n
       ) ;_ 结束setq
       (if (equal d0 1.0 0.001)
         (setq plist (cons (vlax-curve-getPointAtParam
        ent
        (+ 0.5 param)
      )
      plist
       )
         )
         (repeat k
    (setq plist (cons (vlax-curve-getPointAtParam
          ent
          (setq param (+ param d0))
        )
        plist
         )
    )
         )
       )
     ) ;_ 结束progn
   ) ;_ 结束if
   )
     )
   (setq n (1+ n))
        ) ;_ 结束repeat
        (if (not (vlax-curve-isClosed ent))
   (setq plist (cons (vlax-curve-getEndPoint ent) plist))
        ) ;_ 结束if
        (reverse plist)
      )
    )
  )
    )
  )
)
;;;***************** 函数 gxl-get_poly_ptList3*****************
;;;*************函数 gxl-sel-ss-》ax：array.lsp  *************
;;;===================================================================
;;;gxl-Sel-SS->AX:Array 转换选择集为变体数组
;|功能  
转换选择集为变体数组  
语法  
(selectionsetToArray ss)  
参数  
ss: 选择集  
返回值  
变体数组  
样例  
(selectionsetToArray mySS)  
说明  
使用该函数可以将选择集转换为数组传递给ActiveX函数。
如果需要其它的子类型，只需更改引用vlax-vbObject。  
|;
;;;===================================================================
(defun gxl-Sel-SS->AX:Array (ss / c r en)
  (repeat (setq c (sslength ss))
    (setq en (ssname ss (setq c (1- c))))
    (if    (entget en)
      (setq r (cons en r))
    )
  )
  (vlax-safearray-fill
    (vlax-make-safearray
      vlax-vbObject
      (cons 0 (1- (length r)))
    )
    (mapcar 'vlax-ename->vla-object r)
  )
)
;;;***************** 函数 gxl-Sel-SS->AX:Array*****************
;;;*************函数 gxl-ax：addblock.lsp  *************
;;;===================================================================
;;;(gxl-AX:AddBlock InsPt Name) 增加块定义(做块头)，返回块定义 OBJ
(defun gxl-AX:AddBlock (InsPt Name)
  (if (= (substr (strcase name) 1 2) "*U") (setq name "*U"))
(vla-add (vla-get-Blocks *AcDocument*) (vlax-3d-point InsPt) Name)
  )
;;;***************** 函数 gxl-AX:AddBlock*****************
;;;*************函数 gxl-str-subst.lsp  *************
 ;_ end of defun
;;; (gxl-Str-Subst New Old Str) 替换字符串中的某些字符为其它字符
;;;(gxl-Str-Subst  ",." ".." "123..456..789")
(defun gxl-Str-Subst (New Old Str / str1 n)
  (setq n (strlen old))
  (cond    ((> (strlen str) n)
  (setq str1 (substr str 1 n))
  (if (= str1 old)
    (strcat new (gxl-Str-Subst new old (substr str (1+ n))))
    (strcat (substr str 1 1) (gxl-Str-Subst new old (substr str 2)))
    )
    )
    ((= (strlen str) n)
  (if (= old str)
    new
    str
    )
    )
    (t
  str
    )
  ) ;_ 结束cond
  )
;;;***************** 函数 gxl-Str-Subst*****************
;;;*************函数 gxl-blk-check.lsp  *************
;;; gxl-Blk-Check 检查定义图块
(defun gxl-Blk-Check (B_Name / $PROMPT B_NAME1 CURLAY ERR)
  (if (or (= 'SUBR (type MakeBlock-001))
   (= 'USUBR (type MakeBlock-001))
   )
    ()
    (setq $prompt (load "MakeBlockSymbol.vlx" "未找到MakeBlockSymbol.vlx文件"))
    )
  (if (= $prompt "未找到MakeBlockSymbol.vlx文件")
    (setq $prompt (load "E:\\lisp\\房产CAD工具软件\\lisp\\MakeBlockSymbol.vlx" "未找到MakeBlockSymbol.vlx文件"))
    )
  ;(if (= $prompt "未找到MakeBlockSymbol.vlx文件") (progn (princ "\n未找到MakeBlockSymbol.vlx文件") (exit)))
  (if (= $prompt "未找到MakeBlockSymbol.vlx文件")
    B_Name
    (progn
  (setq B_Name1 (gxl-Str-Subst "]" ")" (gxl-Str-Subst "[" "(" B_Name)))
  (setq curlay (getvar "Clayer"))
  (setq err (VL-CATCH-ALL-APPLY 'vla-Item (list (vla-get-Blocks *ACDOCUMENT*) B_Name)))
  (if (VL-CATCH-ALL-ERROR-P err) ;(not (member B_Name (gxl-TABLE "block")))
    (progn
      (if (or (= 'USUBR (type (eval(read (strcat "MakeBlock-" B_Name1)))))
       (= 'SUBR (type (eval(read (strcat "MakeBlock-" B_Name1)))))
       )
    (eval (read (strcat "(MakeBlock-" B_Name1 ")")))
    )
      )
    )
  (setvar "clayer" curlay)
  B_Name
  )
    )
  )
;;;***************** 函数 gxl-Blk-Check*****************
;;;*************函数 gxl-ax：minsertblock.lsp  *************
;;;(gxl-AX:MInsertBlock InsPt Name Xscale Yscale ZScale Rotation NumRows NumColumns RowSpacing ColumnSpacing) 插入复杂块
;;;(gxl-AX:MInsertBlock InsPt Name Xscale Yscale ZScale Rotation) 插入复杂图块,返回BlockREf
;;;(gxl-AX:MInsertBlock (getpoint) "001" 1 1 1 0 2 2 10 10)
(defun gxl-AX:MInsertBlock (InsPt Name Xscale Yscale ZScale Rotation NumRows NumColumns RowSpacing ColumnSpacing)
  (gxl-BLK-CHECK Name)
  (setvar "insname" (VL-FILENAME-BASE name))
  (VL-CATCH-ALL-APPLY 'vla-AddMInsertBlock (list *MODEL-SPACE* (vlax-3d-point InsPt) Name Xscale Yscale ZScale Rotation NumRows NumColumns RowSpacing ColumnSpacing))
  )
;;;***************** 函数 gxl-AX:MInsertBlock*****************
;;;*************函数 gxl-blk-unmblockbase.lsp  *************
;;(gxl-BLK-UnMBlockBase ss base) 制作无名复杂块，base 为图块基点 或 0 = 中心 1 = 左下 2 = 右下 3 = 右上 4 = 左上 ，默认值为0
(defun gxl-BLK-UnMBlockBase (ss base / obj blkName obj1 cp)
  (if (> (sslength ss) 0)
    (progn
  (setq blkName "*U")
  (setq ss (gxl-Sel-SS->AX:Array ss))
  (setq obj (gxl-AX:AddBlock '(0 0 0) blkName))
  (vla-CopyObjects *AcDocument* ss obj)
  (foreach ent (vlax-safearray->list ss)
    (VL-CATCH-ALL-APPLY 'vla-Delete (list ent))
  ) ;_ foreach
  (setq obj1 (gxl-AX:MInsertBlock '(0 0 0) (vla-get-name obj) 1 1 1 0 1 1 0 0))
    ;;计算基点
  (cond
    ((= 'list (type base))
     (setq cp base)
     )
    ((or (null base)
  (= 0 base)
  )
     (vla-GetBoundingBox obj1 'll 'ur)
     (setq ll (vlax-safearray->list ll)
    ur (vlax-safearray->list ur)
    )
     (setq cp (gxl-MIDPOINT ll ur))
     )
    ((= 1 base)
     (vla-GetBoundingBox obj1 'll 'ur)
     (setq ll (vlax-safearray->list ll)
    ;ur (vlax-safearray->list ur)
    )
     (setq cp ll)
     )
    ((= 2 base)
     (vla-GetBoundingBox obj1 'll 'ur)
     (setq ll (vlax-safearray->list ll)
    ur (vlax-safearray->list ur)
    )
     (setq cp (list (car ur) (cadr ll) 0))
     )
    ((= 3 base)
     (vla-GetBoundingBox obj1 'll 'ur)
     (setq ;ll (vlax-safearray->list ll)
    ur (vlax-safearray->list ur)
    )
     (setq cp ur)
     )
    ((= 4 base)
     (vla-GetBoundingBox obj1 'll 'ur)
     (setq ll (vlax-safearray->list ll)
    ur (vlax-safearray->list ur)
    )
     (setq cp (list (car ll) (cadr ur) 0))
     )
    )
  ;;修改图块基点
  (vla-put-Origin obj (vlax-3d-point cp))
  (vla-move obj1 (vlax-3d-point '(0 0 0)) (vlax-3d-point cp))
  obj1
  )
    )
)
;;;***************** 函数 gxl-BLK-UnMBlockBase*****************
;;;*************函数 gxl-ax：addline.lsp  *************
;;;===================================================================
;;; (gxl-AX:AddLine obj pt1 pt2) 制造直线实体
(defun gxl-AX:AddLine (obj pt1 pt2)
  (vla-Addline
    (if obj obj (gxl-GETSPACE))
    (vlax-3d-point pt1)
    (vlax-3d-point pt2)
  ) ;_ 结束vla-Addline
)
;;;***************** 函数 gxl-AX:AddLine*****************
;;;*************函数 gxl-ax：getboundingbox.lsp  *************
;;;==================================================================
;;;gxl-ax:GetBoundingBox 返回一个单独图元的范围
;|功能  
返回一个单独图元的范围  
语法  
(gxl-ax:GetBoundingBox ent)  
参数  
一个图元名称  
样例  
(gxl-ax:GetBoundingBox (car (entsel)))  
说明  
不要使用该程序于XLINES或RAYS  
|;
;;;==================================================================
(defun gxl-ax:GetBoundingBox (ent / ll ur r)
  (if (= 'ENAME (type ent))
    (setq r (VL-CATCH-ALL-APPLY
       'vla-getboundingbox
       (list (vlax-ename->vla-object ent) 'll 'ur)
     )
    )
    (setq r (VL-CATCH-ALL-APPLY 'vla-getboundingbox (list ent 'll 'ur)))
  )
  (if (not (VL-CATCH-ALL-ERROR-P r))
    (mapcar 'vlax-safearray->list (list ll ur))
  )
)
;;;***************** 函数 gxl-ax:GetBoundingBox*****************
;;;*************函数 gxl-mat：scaling.lsp  *************
;;;-----------------------------------------------------------;;
;;; 比例缩放矩阵           ;;
;;; 参数:            ;;
;;; Cen   - 基点                                              ;;
;;; scale - 缩放比例                                          ;;
;;;-----------------------------------------------------------;;
;;;-----------------=={ Scale by Matrix }==-------------------;;
;;;                                                           ;;
;;; Scaling Matrix                                            ;;
;;;-----------------------------------------------------------;;
;;; Author: highflybird, Copyright ? 2012                     ;;
;;;-----------------------------------------------------------;;
;;; Arguments:                                                ;;
;;; Cen    - Base Point for Scaling Transformation            ;;
;;; scale  - Scale Factor by which to scale object            ;;
;;;-----------------------------------------------------------;;
(defun gxl-MAT:Scaling ( Cen scale / s)
  (setq s (- 1 scale))  
  (list
    (list scale 0. 0. (* s (car Cen)))
    (list 0. scale 0. (* s (cadr Cen)))
    (list 0. 0. scale (* s (caddr Cen)))
    '(0. 0. 0. 1.)
  )
)
;;;***************** 函数 gxl-MAT:Scaling*****************
;;;*************函数 gxl-itemsall.lsp  *************
;;;gxl-ItemsAll collection )返回集合全部成员表
;;(gxl-ItemsAll (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object))))
(defun gxl-ItemsAll (collection / result)
  (vl-catch-all-apply
    (FUNCTION
      (lambda ()
    (vlax-for item collection (setq result (cons item result)))
    (reverse result)
      )
    )
  )
  result
)
;;;***************** 函数 gxl-ItemsAll*****************
;;;*************函数 gxl-setoverride.lsp  *************
;;修正放大对象的替换样式
;|设置实体的OverRide参数：
e ---- 实体名   scl -- 比例返回值：
t说明：本函数支持嵌套图块本函数根据比例设置实体的OverRide,对LWPOLYLINE的线宽，
尺寸标注的界限长度，文字、箭头大小，HATCH的填充比例, TEXT,MTEXT,ATTRIB根据比
例的倒数缩放。以满足局部放大后的上述实体的显示要求。
 |;
(defun Gxl-setOverride (e      scl    /      basept1
                               basept2       box    cen    class
                               cwidth dis    e1     i      info
                               lscl   mat    mat0   name   nums
                               obj    p1     p2     pj     pts
                               scl1   ss1    vec    w obj w1 w2
                               objs objs1 atts objname)
  (if (= 'ename (type e))
    (setq obj (vlax-ename->vla-object e))
    (setq obj e e (vlax-vla-object->ename obj))
    )
  (setq class (gxl-dxf e 0) )
  (cond ((or (= class "TEXT") (= class "MTEXT") (= class "ATTRIB") (= class "TCH_TEXT"))
         (setq box  (gxl-ax:GetBoundingBox e)
               cen  (apply 'GXL-MIDPOINT box)
               mat  (Gxl-MAT:Scaling cen  (/ 1.0 scl) )
               )
         (vla-TransformBy obj (vlax-tmatrix mat))
         )
        ((= class "DIMENSION")
         (vla-put-TextHeight obj (/ (vla-get-TextHeight obj) scl))
         (vla-put-ArrowheadSize obj (/ (vla-get-ArrowheadSize obj) scl))
         (if (vlax-property-available-p obj 'ExtensionLineOffset)
         (VL-CATCH-ALL-APPLY 'vla-put-ExtensionLineOffset (list obj (/ (vla-get-ExtensionLineOffset obj) scl)))
           )
         (if (vlax-property-available-p obj 'ExtensionLineExtend)
         (VL-CATCH-ALL-APPLY 'vla-put-ExtensionLineExtend (list obj (/ (vla-get-ExtensionLineExtend obj) scl)))
         )
         )
        ((= class "HATCH")
  (if (gxl-dxf e 41)
         (vla-put-PatternScale obj (/ (gxl-dxf e 41) scl))
    )
         )
        ((= class "LWPOLYLINE")
         (setq cwidth (gxl-dxf e 43))
         (cond ((not cwidth)
                (setq nums (fix(vlax-curve-getEndParam e)))
                (setq i 0)
                (repeat (1- nums)
    (VL-CATCH-ALL-APPLY 'vla-getwidth (list obj i 'w1 'w2))
    (if (and w1 w2)
                  (setq w1 (/ w1 scl)
                        w2 (/ w1 scl)
                        )
      )
                  (VL-CATCH-ALL-APPLY 'vla-SetWidth (list obj i w1 w2))
                  (setq i (1+ i))
                  )
                )
               ((/= 0 cwidth)
                (GXL-CH_ENT e 43 (/ cwidth scl))
                )
               )
         )
        ((= class "INSERT")
         (setq name (gxl-dxf e 2))
         (setq atts (vlax-invoke obj 'GetAttributes))
         (foreach a atts (VL-CATCH-ALL-APPLY 'Gxl-setOverride (list a scl)))
         (if (setq
               objs1 (GXL-ITEMSALL
                       (vla-item (vla-get-blocks *ACDOCUMENT*) name)
                       )
               )
           (foreach a objs1
             (setq objname (gxl-dxf (vlax-vla-object->ename a) 0))
             (cond
               ((= objname "DIMENSION")
                (setq objs
                       (vlax-invoke *ACDOCUMENT* 'CopyObjects (list a) *SPACE*)
                      )
                (VL-CATCH-ALL-APPLY 'vla-delete (list a))
                (foreach a objs
                  (Gxl-setOverride a scl)
                  )
                (if objs
                  (vlax-invoke
                    *ACDOCUMENT*
                    'CopyObjects
                    objs
                    (vla-item (vla-get-blocks *ACDOCUMENT*) name)
                    )
                  )
                (foreach a objs
                  (VL-CATCH-ALL-APPLY 'vla-delete (list a))
                  )
                )
               (t
                (VL-CATCH-ALL-APPLY 'Gxl-setOverride (list a scl))
                )
               )
             )
           )
         )
        (t (if (vlax-property-available-p obj 'LinetypeScale) (vla-put-LinetypeScale obj (/ (vla-get-LinetypeScale obj) scl))))
        )
  t
  )
;;;***************** 函数 gxl-setOverride*****************
;;;*************函数 gxl-lst-split.lsp  *************
;;;(gxl-lst-split lst n)将表等分成若干长度为n的子表
;(setq a '(1 2 3 4 5 6 7 8))
;(gxl-lst-split  a 2)  返回  ((1 2) (3 4) (5 6) (7 8))
;(gxl-lst-split  a 3)  返回  ((1 2 3) (4 5 6) (7 8))
;(gxl-lst-split '(0 1 2 3 4 5 6 7 8 9 10 11) 3)
;;;递归算法
(defun gxl-lst-split (lst len / tmp)
  (if lst
    (cons
      (reverse
    (repeat    len
   (if (car lst)
     (setq tmp (cons (car lst) tmp)
    lst (cdr lst)
     )
   )
   tmp ;_ 制造返回值
    )
      )
      (gxl-lst-split lst len)
    )
  )
)
;;;***************** 函数 gxl-lst-split*****************
;;;*************函数 gxl-inters.lsp  *************
;;;(gxl-inters en1 en2 Param) 计算两曲线交点,param : acExtendNone acExtendThisEntity acExtendOtherEntity acExtendBoth
;;;(gxl-inters (car (entsel)) (car (entsel)) 0)
(defun gxl-inters (obj1 obj2 param)
  (if (= 'ENAME (type obj1))
    (setq obj1 (vlax-ename->vla-object obj1))
    (if    (= 'STR (type obj1))
      (setq obj1 (vlax-ename->vla-object (handent obj1)))
    )
  )
  (if (= 'ENAME (type obj2))
    (setq obj2 (vlax-ename->vla-object obj2))
    (if    (= 'STR (type obj2))
      (setq obj2 (vlax-ename->vla-object (handent obj2)))
    )
  )
  (if (and obj1 obj2)
    (gxl-lst-split
      (vlax-invoke obj1 'IntersectWith obj2 param)
      3
    )
  )
)
;;;***************** 函数 gxl-inters*****************
;;;*************************************************
(defun c:ZoomMap (/ KD    DELFLAG  CP    R      GR     D
      P1    ENT   FLAG  SCALE    PL     SS     ENDENT
      UNBLK  NEWENT OLDPT  ENLINE    PTS *error* os cmdecho)
  (defun *error* (s)
    (command "_ucs" "_p")
    (setvar 'cmdecho cmdecho)
    (gxl-RESTORESLAYERS)
    (if os (setvar 'osmode os))
    (if unblk (vla-delete unblk))
    (if NewEnt (vla-delete NewEnt))
    (if enline (entdel enline))
    (if delflag (entdel ent))
    (princ s)
    (princ)
    )
  (setq cmdecho (getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (command "_ucs" "_w")
  (gxl-storeslayers)
  (gxl-Layer-UnLockAll)
  (setvar "clayer" "0")
  (initget 7 "Select Rect Draw Circle  ")
  (setq kd (getkword "\n**选择放大范围方式[选择多边形Select/四边形R/绘制多边形Draw/圆形放大Circle]<Circle>:"))
  (if (= "" kd) (setq kd "Circle"))
  (while (not ent)
  (cond    ((= kd "Circle")
  (setq delflag t)
  (while (not (setq cp (getpoint "\n 选择放大区域中心点："))))
  (setq R 0 flag nil)
  (while    (not flag)
    (setq gr (grread t 2))
    (setq d (* 0.0015 (getvar "viewsize")))
    (gxl-Ge-GRDrawCross cp 5 0 1 nil)
    (cond ((= 5 (car gr))
                  (setq p1 (cadr gr))
                  (if (> (abs (- (distance cp p1) R)) d)
                    (progn
                      (setq R (distance cp p1))
                      (if ent
                        (gxl-ch_ent ent 40 r)
                        (progn
                          (gxl-AX:ADDCIRCLE *MODEL-SPACE* cp r)
                          (setq ent (entlast))
                          )
                        )
                                                            ;(gxl-CH_ENT ent 62 1)
                      )
                    )
                  )
                 ((= 3 (car gr))
                  (setq flag t)
                  (setq p1 (cadr gr))
                  (setq R (distance cp p1))
                  (if ent
                    (gxl-ch_ent ent 40 r)
                    (progn
                      (gxl-AX:ADDCIRCLE *MODEL-SPACE* cp r)
                      (setq ent (entlast))
                      )
                    )
                  )
                 )
  )
    )
    ((= kd "Rect")
  (setq delflag t)
  (if (setq ent (gxl-COMMAND "_.rectang"))
    (progn
  (setq ent (entlast))
  (gxl-ch_ent ent 70 1)
  (setq cp (apply 'gxl-MIDPOINT (gxl-GETBOX ent)))
  (setq d (* 0.0015 (getvar "viewsize")))
    (gxl-Ge-GRDrawCross cp 5 0 1 nil)
  )
    )
    )
    ((= kd "Draw")
  (setq delflag t)
  (if (setq ent (gxl-COMMAND "_.Pline"))
    (progn
  (setq ent (entlast))
  (gxl-ch_ent ent 70 1)
  (setq cp (apply 'gxl-MIDPOINT (gxl-GETBOX ent)))
  (setq d (* 0.0015 (getvar "viewsize")))
    (gxl-Ge-GRDrawCross cp 5 0 1 nil)
  )
    )
    )
    ((= kd "Select")
  (while (not (setq ent (car (gxl-SEL-ENTSEL "\n选择封闭多段线:" '((0 . "*LWPOLYLINE,circle")))))))
  (setq cp (apply 'gxl-MIDPOINT (gxl-GETBOX ent)))
  (setq d (* 0.0015 (getvar "viewsize")))
    (gxl-Ge-GRDrawCross cp 5 0 1 nil)
    )
  )
    (if (not ent)
      (cond
    ((= kd "Select")
  (princ "\n***没有选择放大边界，请重新选择边界***")
  )
    (t
  (princ "\n***没有绘制放大边界，请重新绘制边界***")
  )
    )
      )
    )
  (setq os (getvar 'osmode))
  (setvar 'osmode 0)
  (setq p1 (vlax-3d-point cp))
  (setq scale (getreal "\n 放大倍数<2.0>："))
  (if (null scale) (setq scale 2.0))
  (redraw ent 2)
  (setq pl (gxl-get_poly_ptList3 ent 0.017))
  (setq ss (ssget "cp" pl))
  (if ss
    (progn
      (setq endent (entlast))
      (command "_copy" ss "" "0,0" "0,0")
      (setq ss (gxl-SEL-ENTNEXTALL endent))
  (setq unblk (gxl-BLK-UnMBlockBase ss cp))
  (command "_xclip" (entlast) "" "n" "p")
  (foreach a pl (command a))
  (command "")
  (redraw ent 1)
  (setq NewEnt (vla-copy (vlax-ename->vla-object ent)))
  (vla-ScaleEntity NewEnt (setq oldpt (vlax-3d-point cp)) scale)
  (princ "\n 摆放位置：")
  (setq flag t)
  (while flag
    (setq gr (grread t 2))
    (gxl-Ge-GRDrawCross cp 5 0 1 nil)
    (if (= 5 (car gr))
      (progn
    (vla-move NewEnt p1 (setq p1 (vlax-3d-point (cadr gr))))
    (if enline
   (gxl-CH_ENT enline 11 (apply 'gxl-MIDPOINT (gxl-GETBOX NewEnt)))
   (progn
     (gxl-AX:ADDLINE *MODEL-SPACE* cp (cadr gr))
     (setq enline (entlast))
     )
   )
       )
      (setq flag nil)
      )
    )
      (vla-move unblk (vlax-3d-point cp) p1)
      (vla-ScaleEntity unblk p1 scale)
      (gxl-setOverride (vlax-vla-object->ename unblk) scale)
      (setq pts (gxl-inters enline NewEnt acExtendNone))
      (gxl-CH_ENT enline 11 (car pts))
      (setq pts (gxl-inters enline Ent acExtendNone))
      (gxl-CH_ENT enline 10 (car pts))
      (gxl-ch_ent ent 62 3)
      (gxl-ch_ent enline 62 3)
      (vla-put-color NewEnt 3)
  )
    (alert "所选范围没有任何实体！")
    )
  (command "_ucs" "_p")
   (setvar 'osmode os)
  (setvar 'cmdecho cmdecho)
 (gxl-RESTORESLAYERS)
  (princ)
  )
(princ "\n** 局部放大图 By Gu_xl 2013.07.24 命令: ZoomMap **") (princ)