[求助]哪位高手相助！

vvc221

哪位高手相助！遍历块时取得块内的点数据理不对！程序目的：想遍历块内的线的数据，提取块内线的点的数据!程序结果：提取的单层或多层最外层块的线的点的数据正确。但旋转的单层或多层块均不正确。cad图内有详细图例！是不是函数:mcs->wcs-point-4x 有问题。我想可能是坐标系与矩阵这方面没有掌握好。但这方面根本没有资料，我所接触到的只是cad帮助里面的一些简单介绍。哪位大侠有没有这方面全面点的资料啊。[

alin

;;;   NCOPY.LSP  
;;;   (C) Copyright 1988-1992 by Autodesk, Inc.
;;;    
;;;   This program is copyrighted by Autodesk, Inc. and is  licensed
;;;   to you under the following conditions.  You may not distribute
;;;   or  publish the source code of this program in any form.   You
;;;   may  incorporate this code in object form in derivative  works
;;;   provided  such  derivative  works  are  (i.) are  designed and
;;;   intended  to  work  solely  with  Autodesk, Inc. products, and
;;;   (ii.)  contain  Autodesk's  copyright  notice  "(C)  Copyright
;;;   1988-1992 by Autodesk, Inc."
;;;
;;;   AUTODESK  PROVIDES THIS PROGRAM "AS IS" AND WITH  ALL  FAULTS.
;;;   AUTODESK  SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF  MER-
;;;   CHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK,  INC.
;;;   DOES  NOT  WARRANT THAT THE OPERATION OF THE PROGRAM  WILL  BE
;;;   UNINTERRUPTED OR ERROR FREE.
;;;
;;;   By Troy Davis
;;;   20 August 1991
;;;
;;; DESCRIPTION
;;;
;;;   C:NCOPY -- Nested entity COPY routine.
;;;   
;;;   This command will create a new entity that duplicates the selected
;;;   entity, even if the selected entity is nested within a block (or
;;;   blocks) with unequal scale factors or non-parallel UCSs.  If the
;;;   selected entity is not contained within a block, a duplicate is
;;;   created as well (for alternate behavior, see the no_op function
;;;   definition, below).
;;;
;;;   The C:NCOPYSET command allows control over copying a single selected
;;;   entity or all of the entities at the same nesting level within the
;;;   same block as the selected entity.
;;;
;;;   All entity properties are preserved; properties not defined assume
;;;   the current defaults.
;;;
;;; CAVEATS
;;;
;;;   ARCs and CIRCLEs within block structures with unequal ABSOLUTE scale
;;;   factors are rejected with a message.  Mirrored blocks are okay.
;;;
;;;   TEXT entities and attributes found within blocks with unequal
;;;   absolute scale factors are copied, allowing access to the text string,
;;;   but the results may display differently than the original due to the
;;;   block's scale factors changing the appearance of the text style.
;;;   A message is issued when this occurs.
;;;
;;;   2D POLYLINEs that are found within blocks with unequal absolute scale
;;;   factors lose their width information.  Additionally, polyline arc
;;;   segments found within blocks with unequal absolute scale factors lose
;;;   their bulge information.  All original vertex locations are retained,
;;;   and a message is issued when this occurs.  If the containing block(s)
;;;   have equal absolute scale factors, bulge information is retained and
;;;   the width is scaled appropriately.
;;;   
;;; GLOBALS USED
;;;   nc:bx   nc:blkrot    nc:tflag    nc:olderr
;;;   nc:by   nc:b210      nc:pwflag   nc:wbprompt
;;;   nc:bz   nc:allsfeq   nc:paflag   nc:wholeblk
;;;
;;;   nc:sset -- this selection set is created when the option to copy
;;;              all entities within the same block is used.  It is cleared
;;;              each time NCOPY is used.  See the comments for C:NCOPYSET.
;;;--------------------------------------------------------------------------


;;; NCINE -- Nested LINE entities.
;;;
;;;         Start point, end point, and normal are transformed.
;;;         World entities go from MCS to current UCS via (nc:xform)
;;;         in one step.

(defun nc:line (e / e10 e11 e210 x10 x11 x210 new1 new2 new3)
  (setq e10  (cdr (assoc 10 e))
        e11  (cdr (assoc 11 e))
        e210 (cdr (assoc 210 e))

        x10  (nc:xform e10 matrix nil)
        x11  (nc:xform e11 matrix nil)
        x210 (nc:univ (nc:xform e210 matrix T))

        new1 (subst (cons 10 x10) (assoc 10 e) e)
        new2 (subst (cons 11 x11) (assoc 11 new1) new1)
        new3 (subst (cons 210 x210) (assoc 210 new2) new2)
  )
  (entmake (cdr new3))
)


;;; NC:CIRCLE -- Nested CIRCLE entities.
;;;
;;;         Center point and normal are transformed.  Radius is
;;;         scaled by the total X axis scaling of nested block(s).
;;;         Reject circles if total absolute scale factors are not
;;;         equal; mirrored blocks are ok.
;;;
;;;         Planar entities require transformation (trans) of their
;;;         points from ECS to MCS before transformation (nc:xform)
;;;         to the UCS.  Follow the steps for e10/w10/x10/n10, below.

(defun nc:circle (e / e210 e10 e40 w10 x10 x210 n10 n40 new1 new2 new3)
  (if nc:allsfeq
    (progn
      (setq e10  (cdr (assoc 10 e))
            e40  (cdr (assoc 40 e))
            e210 (cdr (assoc 210 e))

            w10  (trans e10 e210 0)

            x10  (nc:xform w10 matrix nil)
            x210 (nc:univ (nc:xform e210 matrix T))

            n10  (trans x10 0 x210)
            n40  (abs (* e40 nc:bx))

            new1 (subst (cons 10 n10) (assoc 10 e) e)
            new2 (subst (cons 40 n40) (assoc 40 new1) new1)
            new3 (subst (cons 210 x210) (assoc 210 new2) new2)
      )
      (entmake (cdr new3))
    )
    (progn
      (princ "\nCircles must be in blocks with equal absolute scale factors.")
      (princ)
    )
  )
)


;;; NC:INSERT -- Nested INSERT entities.
;;;
;;;         The insertion point, rotation angle, and normal are
;;;         transformed.  The scale factors are multiplied by the
;;;         totals of all the nested blocks.

(defun nc:insert (e / e10 e50 e210 w10 x10 x210 abxe abxw abxx ang
                    n50 n10 n41 n42 n43 new1 new2 new3 new4 new5 new6
               )
  (setq e10  (cdr (assoc 10 e))
        e50  (cdr (assoc 50 e))
        e210 (cdr (assoc 210 e))
        w10  (trans e10 e210 0)
        x10  (nc:xform w10 matrix nil)
        x210 (nc:univ (nc:xform e210 matrix T))
  )
  (if (or (equal nc:b210 '(0.0 0.0 1.0) 1e-06)
          (equal nc:b210 '(0.0 0.0 -1.0) 1e-06)
      )
    (if (equal (nc:univ e210) '(0.0 0.0 1.0) 1e-06)
      (setq n50 (+ e50 nc:blkrot))
      (if (equal (nc:univ e210) '(0.0 0.0 -1.0) 1e-06)
        (setq n50 (- e50 nc:blkrot))
        (progn
          (setq abxe (car (nc:arbaxis e210))
                abxw (nc:univ (nc:xform abxe matrix T))

                abxx (nc:univ (car (nc:arbaxis x210)))
                ang  (nc:ang3dv abxw abxx)
          )
          (if (> 0.0 (caddr abxw))
            (setq n50 (- e50 ang))
            (setq n50 (+ e50 ang))
          )
        )
      )
    )
    (progn
      (setq abxe (car (nc:arbaxis e210))
            abxw (nc:univ (nc:xform abxe matrix T))
            abxx (nc:univ (car (nc:arbaxis x210)))
            ang  (nc:ang3dv abxw abxx)
      )
      (if (> 0.0 (caddr abxw))
        (setq n50 (- e50 ang))
        (setq n50 (+ e50 ang))
      )
    )
  )
  (setq n10 (trans x10 0 x210)
        n41  nc:bx
        n42  nc:by
        n43  nc:bz
        new1 (subst (cons 10 n10) (assoc 10 e) e)
        new2 (subst (cons 41 n41) (assoc 41 new1) new1)
        new3 (subst (cons 42 n42) (assoc 42 new2) new2)
        new4 (subst (cons 43 n43) (assoc 43 new3) new3)
        new5 (subst (cons 50 n50) (assoc 50 new4) new4)
        new6 (subst (cons 210 x210) (assoc 210 new5) new5)
  )
  (entmake (cdr new6))
)


;;; NC:TEXT -- Nested TEXT entities (includes ATTDEFs and ATTRIBs).
;;;
;;;         The insertion point, justification point and normal
;;;         is transformed.  The rotation angle is recalculated
;;;         by finding the angle between the entity's ECS arb-X
;;;         and the current ECS arb-X direction and adding (or
;;;         subtracting) that angle from the original's rotation
;;;         angle.  Most of the code is to deal with zero totals
;;;         and zero differences.  nc:tflag is set so that the
;;;         message is issued only once per command, regardless
;;;         of the number of text entities found.

(defun nc:text (e / e10 e11 e210 e50 w10 w11 x10 x11 x210 n10 n11
                  abxe abxw abxx ang n50 new1 new2 new3 new4
             )
  (if (and (not nc:allsfeq)
           nc:tflag
      )
      (progn
        (princ "\nTEXT found with unequal scale factors -- results may vary.")
        (setq nc:tflag nil)
      )
  )
  (setq e10  (cdr (assoc 10 e))
        e11  (cdr (assoc 11 e))
        e50  (cdr (assoc 50 e))
        e210 (cdr (assoc 210 e))

        w10  (trans e10 e210 0)
        w11  (trans e11 e210 0)

        x10  (nc:xform w10 matrix nil)
        x11  (nc:xform w11 matrix nil)
        x210 (nc:univ (nc:xform e210 matrix T))

        n10  (trans x10 0 x210)
        n11  (trans x11 0 x210)
  )
  (if (or (equal nc:b210 '(0.0 0.0 1.0) 1e-06)
          (equal nc:b210 '(0.0 0.0 -1.0) 1e-06)
      )
    (if (equal (nc:univ e210) '(0.0 0.0 1.0) 1e-06)
      (setq n50 (+ e50 nc:blkrot))
      (if (equal (nc:univ e210) '(0.0 0.0 -1.0) 1e-06)
        (setq n50 (- e50 nc:blkrot))
        (progn
          (setq abxe (car (nc:arbaxis e210))
                abxw (nc:univ (nc:xform abxe matrix T))

                abxx (nc:univ (car (nc:arbaxis x210)))
                ang  (nc:ang3dv abxw abxx)
          )
          (if (> 0.0 (caddr abxw))
            (setq n50 (- e50 ang))
            (setq n50 (+ e50 ang))
          )
        )
      )
    )
    (progn
      (setq abxe (car (nc:arbaxis e210))
            abxw (nc:univ (nc:xform abxe matrix T))

            abxx (nc:univ (car (nc:arbaxis x210)))
            ang  (nc:ang3dv abxw abxx)
      )
      (if (> 0.0 (caddr abxw))
        (setq n50 (- e50 ang))
        (setq n50 (+ e50 ang))
      )
    )
  )
  (setq new1 (subst (cons 10 n10) (assoc 10 e) e)
        new2 (subst (cons 11 n11) (assoc 11 new1) new1)
        new3 (subst (cons 50 n50) (assoc 50 new2) new2)
        new4 (subst (cons 210 x210) (assoc 210 new3) new3)
  )
  (entmake (cdr new4))
)


;;; NC:POINT -- Nested POINT entities.
;;;
;;;         The definition point and normal are transformed.

(defun nc:point (e / e10 e210 w210 w10 x210 x10 new1 new2)
  (setq e10  (cdr (assoc 10 e))
        e210 (cdr (assoc 210 e))

        w10  (trans e10 e210 0)
        w210 (trans e210 e210 0 T)
        
        x10  (nc:xform w10 matrix nil)
        x210 (nc:univ (nc:xform w210 matrix T))

        new1 (subst (cons 10 x10) (assoc 10 e) e)
        new2 (subst (cons 210 x210) (assoc 210 new1) new1)
  )
  (entmake (cdr new2))
)


;;; NTRACE -- Nested TRACE entities.
;;;
;;;         The corner points and the normal are transformed.
;;;         TRACEs are planar entities, so there is the additional step.
;;;         SOLID entities (not AME composites) are handled here, as well.

(defun nc:trace (e / e10 e11 e12 e13 e210 w10 w11 w12 w13 x10 x11 x12 x13
                     x210 n10 n11 n12 n13 new1 new2 new3 new4 new5
                )

  (setq e10  (cdr (assoc 10 e))
        e11  (cdr (assoc 11 e))
        e12  (cdr (assoc 12 e))
        e13  (cdr (assoc 13 e))
        e210 (cdr (assoc 210 e))

        w10  (trans e10 e210 0)
        w11  (trans e11 e210 0)
        w12  (trans e12 e210 0)
        w13  (trans e13 e210 0)

        x10  (nc:xform w10 matrix nil)
        x11  (nc:xform w11 matrix nil)
        x12  (nc:xform w12 matrix nil)
        x13  (nc:xform w13 matrix nil)
        x210 (nc:univ (nc:xform e210 matrix T))

        n10  (trans x10 0 x210)
        n11  (trans x11 0 x210)
        n12  (trans x12 0 x210)
        n13  (trans x13 0 x210)

        new1 (subst (cons 10 n10) (assoc 10 e) e)
        new2 (subst (cons 11 n11) (assoc 11 new1) new1)
        new3 (subst (cons 12 n12) (assoc 12 new2) new2)
        new4 (subst (cons 13 n13) (assoc 13 new3) new3)
        new5 (subst (cons 210 x210) (assoc 210 new4) new4)
  )
  (entmake (cdr new5))
)


;;; NC:3DF -- Nested 3D Faces.   
;;;
;;;         The corner points are transformed.  3DFACES are world entities.

(defun nc:3df (e / e10 e11 e12 e13 x10 x11 x12 x13 new1 new2 new3 new4)
  (setq e10  (cdr (assoc 10 e))
        e11  (cdr (assoc 11 e))
        e12  (cdr (assoc 12 e))
        e13  (cdr (assoc 13 e))

        x10  (nc:xform e10 matrix nil)
        x11  (nc:xform e11 matrix nil)
        x12  (nc:xform e12 matrix nil)
        x13  (nc:xform e13 matrix nil)

        new1 (subst (cons 10 x10) (assoc 10 e) e)
        new2 (subst (cons 11 x11) (assoc 11 new1) new1)
        new3 (subst (cons 12 x12) (assoc 12 new2) new2)
        new4 (subst (cons 13 x13) (assoc 13 new3) new3)
  )
  (entmake (cdr new4))
)


;;; NC:ARC -- Nested ARC entities.
;;;
;;;         Provided that all scale factors' absolute values are equal,
;;;         the center point and the normal are transformed.  The radius
;;;         is multiplied by the total X scale factor(s) of all nested
;;;         block(s).  The beginning and ending angles of arcs are
;;;         based on the ARC's ECS X axis, so the angle between that and
;;;         the ECS X axis for the new arc being created must be added
;;;         (or subtracted) from the arc's data.  Of course, most of the
;;;         code is to handle 0 degree angles or 180 degree angles.

(defun nc:arc (e / e210 e10 e40 e50 e51 w10 x10 x210 abxe abxw abxx ang n50
                 n51 n40 new1 new2 new3 new4 new5
            )

  (if nc:allsfeq
    (progn
      (setq e210 (cdr (assoc 210 e))
            e10  (cdr (assoc 10 e))
            e40  (cdr (assoc 40 e))
            e50  (cdr (assoc 50 e))
            e51  (cdr (assoc 51 e))

            w10  (trans e10 e210 0)
            x10  (nc:xform w10 matrix nil)

            x210 (nc:univ (nc:xform e210 matrix T))
      )
      (if (or (equal nc:b210 '(0.0 0.0 1.0) 1e-06)
              (equal nc:b210 '(0.0 0.0 -1.0) 1e-06)
          )
        (if (equal (nc:univ e210) '(0.0 0.0 1.0) 1e-06)
          (setq n50 (+ e50 nc:blkrot)
                n51 (+ e51 nc:blkrot)
          )
          (if (equal (nc:univ e210) '(0.0 0.0 -1.0) 1e-06)
            (setq n50 (- e50 nc:blkrot)
                  n51 (- e51 nc:blkrot)
            )
            (progn
              (setq abxe (car (nc:arbaxis e210))
                    abxw (nc:univ (nc:xform abxe matrix T))

                    abxx (nc:univ (car (nc:arbaxis x210)))
                    ang  (nc:ang3dv abxw abxx)
              )
              (if (> 0.0 (caddr abxw))
                (setq n50 (- e50 ang)
                      n51 (- e51 ang)
                )
                (setq n50 (+ e50 ang)
                      n51 (+ e51 ang)
                )
              )
            )
          )
        )
        (progn
          (setq abxe (car (nc:arbaxis e210))
                abxw (nc:univ (nc:xform abxe matrix T))

                abxx (nc:univ (car (nc:arbaxis x210)))
                ang  (nc:ang3dv abxw abxx)
          )
          (if (> 0.0 (caddr abxw))
            (setq n50 (- e50 ang)
                  n51 (- e51 ang)
            )
            (setq n50 (+ e50 ang)
                  n51 (+ e51 ang)
            )
          )
        )
      )

      (setq n10  (trans x10 0 x210)
            n40  (abs (* e40 nc:bx))

            new1 (subst (cons 10 n10) (assoc 10 e) e)
            new2 (subst (cons 40 n40) (assoc 40 new1) new1)
            new3 (subst (cons 50 n50) (assoc 50 new2) new2)
            new4 (subst (cons 51 n51) (assoc 51 new3) new3)
            new5 (subst (cons 210 x210) (assoc 210 new4) new4)
      )
      (entmake (cdr new5))
    )
    (progn
      (princ "\nArcs must be in blocks with equal absolute scale factors.")
      (princ)
    )
  )
)


;;; NC:POLY -- Nested POLYlines.
;;;
;;;         This function finds the POLYLINE header and then determines
;;;         the type (2D or 3D) of POLYLINE.  All 3D polylines, meshes
;;;         and polyface meshes are handled the same way.

(defun nc:poly (e / pheader ptype pname phold pflag)
  (setq ptype (cdr (assoc 0 e))
        pname (cdr (assoc -1 e))
        phold e
  )
  (while (/= ptype "SEQEND")
    (setq phold (entget (entnext pname))
          ptype (cdr (assoc 0 phold))
          pname (cdr (assoc -1 phold))
    )
  )
  (setq pheader (entget (cdr (assoc -2 phold)))
        pflag (cdr (assoc 70 pheader))
  )
  (if (< pflag 8)
    (nc:p2d pheader)
    (nc:p3d pheader)
  )
)


;;; NC:P2D -- Nested Polylines, 2D.
;;;
;;;         2D polylines are planar entities that may have width and
;;;         bulge information.  If all scale factors' absolute values
;;;         are equal, the width is scaled by the X scale factor. Bulge
;;;         information remains the same regardless of the scale.  If the
;;;         scale factors are unequal, width and bulge are set to 0.0.
;;;         nc:pwflag and nc:paflag are set so that the messages are issued
;;;         only once per polyline, not for each vertex.

(defun nc:p2d (phead / e10 e210 w10 x10 x210 n10 new1 new2 p40 n40 new3
                     p42 n40 new4 p42 n42 new5 pvert ptype
                     pv10 pvw10 pvx10 pvn10 newv1 pv40 nv40 newv2
                     pv41 nv41 newv3 pv42 nv42 newv4
            )
  (setq e10  (cdr (assoc 10 phead))
        e210 (cdr (assoc 210 phead))
        w10  (trans e10 e210 0)
        x10  (nc:xform w10 matrix nil)
        x210 (nc:univ (nc:xform e210 matrix T))
        n10  (trans x10 0 x210)
        new1 (subst (cons 10 n10) (assoc 10 phead) phead)
        new2 (subst (cons 210 x210) (assoc 210 new1) new1)
  )
  (setq p40 (cdr (assoc 40 new2)))
  (if nc:allsfeq
    (setq n40 (* p40 (abs nc:bx)))
    (progn
      (setq n40 0.0)           
      (if nc:pwflag
        (progn
          (princ "\n2D Polyline found with unequal scale factors -- width lost.")
          (setq nc:pwflag nil)
        )
      )
    )
  )
  (setq new3 (subst (cons 40 n40) (assoc 40 new2) new2)
        p41 (cdr (assoc 41 new3))
  )
  (if nc:allsfeq
    (setq n41 (* p41 (abs nc:bx)))
    (progn
      (setq n41 0.0)           
      (if nc:pwflag
        (progn
          (princ "\n2D Polyline found with unequal scale factors -- width lost.")
          (setq nc:pwflag nil)
        )
      )
    )
  )
  (setq new4 (subst (cons 41 n41) (assoc 41 new3) new3))
  (entmake (cdr new4))
  (setq pvert (entget (entnext (cdr (assoc -1 phead))))
        ptype (cdr (assoc 0 pvert))
  )
  (while (/= ptype "SEQEND")
    (setq pv10  (cdr (assoc 10 pvert))
          pvw10 (trans pv10 e210 0)
          pvx10 (nc:xform pvw10 matrix nil)
          pvn10 (trans pvx10 0 x210)
          newv1 (subst (cons 10 pvn10) (assoc 10 pvert) pvert)
    )
    (setq pv40 (cdr (assoc 40 newv1)))
    (if nc:allsfeq
      (setq nv40 (* pv40 (abs nc:bx)))
      (progn
        (setq nv40 0.0)           
        (if nc:pwflag
          (progn
            (princ "\n2D Polyline found with unequal scale factors -- width lost.")
            (setq nc:pwflag nil)
          )
        )
      )
    )
    (setq newv2 (subst (cons 40 nv40) (assoc 40 newv1) newv1)
          pv41  (cdr (assoc 41 newv2))
    )
    (if nc:allsfeq
      (setq nv41 (* pv41 (abs nc:bx)))
      (progn
        (setq nv41 0.0)           
        (if nc:pwflag
          (progn
            (princ "\n2D Polyline found with unequal scale factors -- width lost.")
            (setq nc:pwflag nil)
          )
        )
      )
    )
    (setq newv3 (subst (cons 41 nv41) (assoc 41 newv2) newv2)
          pv42  (cdr (assoc 42 newv3))
    )
    (if nc:allsfeq
      (setq nv42 pv42)
      (progn
        (setq nv42 0.0)
        (if nc:paflag
          (progn
            (princ "\n2D Polyline arc found with unequal scale factors -- bulge lost.")
            (setq nc:paflag nil)
          )
        )
      )
    )
    (setq newv4 (subst (cons 42 nv42)(assoc 42 newv3) newv3)
          pvert (entget (entnext (cdr (assoc -1 pvert))))
          ptype (cdr (assoc 0 pvert))
    )
    (entmake (cdr newv4))
  )
  (entmake (cdr pvert))
)


;;; NC:P3D -- Nested Polyline, 3D.  Includes meshes and polyface meshes.
;;;
;;;         3D polythings are much simpler than 2D polylines, as there
;;;         is no width or bulge information to process.

(defun nc:p3d (phead / pvert ptype3 e10 x10 new1)
  (entmake (cdr phead))
  (setq pvert (entget (entnext (cdr (assoc -1 phead))))
        ptype3 (cdr (assoc 0 pvert))
  )
  (while (/= ptype3 "SEQEND")
    (setq e10    (cdr (assoc 10 pvert))
          x10    (nc:xform e10 matrix nil)
          new1   (subst (cons 10 x10) (assoc 10 pvert) pvert)
          pvert  (entget (entnext (cdr (assoc -1 pvert))))
          ptype3 (cdr (assoc 0 pvert))
    )
    (entmake (cdr new1))
  )
  (entmake (cdr pvert))
)


;;; NC:ANG3DV -- ANGle between 3D Vectors.

(defun nc:ang3dv (v1 v2)
  (if (not (equal v1 v2 1e-12))
    (nc:arccos
      (/ (nc:dotp v1 v2)
         (* (sqrt (nc:dotp v1 v1))
            (sqrt (nc:dotp v2 v2))
         )
      )
    )
    (eval '0.0)
  )
)


;;; NC:ARCCOS -- Find the arccosine of a given angle.

(defun nc:arccos (ang1)
  (if (not (equal ang1 1.0 1e-06))
    (if (not (equal ang1 -1.0 1e-06))
      (atan (sqrt (- 1.0 (expt ang1 2.0))) ang1)
      (eval pi)
    )
    (eval '0.0)
  )
)


;;; NC:XFORM -- TransFORM a point from the MCS to WCS.
;;;
;;;         This is the function described in the documentation for
;;;         the (nentsel) function.  If v is True, then xpt is a
;;;         vector, not a point, just like (trans).  If v is not True,
;;;         then xpt is a point and the offset from the WCS origin is
;;;         applied.  xpt is a list of three reals.  matrix is a list
;;;         containing four lists of three reals, the caddr of the list
;;;         returned by (nentsel).  v is either T or nil.

(defun nc:xform (xpt matrix v / ex ey ez m1 m2 m3 m4 wx wy wz)
  (setq   ex (car xpt)
          ey (cadr xpt)
          ez (caddr xpt)
          
          m1 (nth 0 matrix)    
          m2 (nth 1 matrix)
          m3 (nth 2 matrix)

          wx (+ (* (car m1) ex)
                (* (car m2) ey)
                (* (car m3) ez)
             )

          wy (+ (* (cadr m1) ex)
                (* (cadr m2) ey)
                (* (cadr m3) ez)
             )

          wz (+ (* (caddr m1) ex)
                (* (caddr m2) ey)
                (* (caddr m3) ez)
             )
  )
  (if (not v)
    (setq m4 (nth 3 matrix)
          wx (+ wx (car m4))
          wy (+ wy (cadr m4))
          wz (+ wz (caddr m4))
    )
  )
  (list wx wy wz)
)


;;; NC:UNIV -- UNIt Vector.
;;;
;;;         Once several vectors are added, multiplied, or otherwise
;;;         manipulated, the values are often greater than the unit total.
;;;         This function insures that a given vector is scaled to unit
;;;         length.  v is a list of three reals.  A list of three reals is
;;;         is returned.

(defun nc:univ (v / vx vy vz d1 d2)
  (if (not (equal v '(0.0 0.0 0.0) 1e-12))
    (progn
      (setq vx (car v) vy (cadr v) vz (caddr v)
            d1 (+ (* vx vx)
                  (* vy vy)
                  (* vz vz)
               )
            d2 (/ 1.0 (sqrt d1))
      )
      (list (* vx d2)
            (* vy d2)
            (* vz d2)
      )
    )
    (list 0.0 0.0 0.0)
  )
)


;;;  NC:DOTP -- DOT Product of two vectors.
;;;
;;;         This function returns the scalar product of two vectors.
;;;         v1 and v2 are lists of three reals.  A real number is returned.

(defun nc:dotp (v1 v2)
  (+
    (* (car v1) (car v2))
    (* (cadr v1) (cadr v2))
    (* (caddr v1) (caddr v2))
  )
)


;;;  NC:CROSSP -- CROSS Product of two vectors.
;;;
;;;         This function returns the vector product of v1 and v2.
;;;         v1 and v2 are lists of three reals.  A list of three reals,
;;;         a vector, is returned

(defun nc:crossp (v1 v2 / v1x v1y v1z v2x v2y v2z)
  (setq v1x (car v1) v1y (cadr v1) v1z (caddr v1)
        v2x (car v2) v2y (cadr v2) v2z (caddr v2)
  )
  (list
    (- (* v1y v2z) (* v1z v2y))
    (- (* v1z v2x) (* v1x v2z))
    (- (* v1x v2y) (* v1y v2x))
  )
)


;;;  NC:ARBAXIS -- determine the ARBitrary AXES of a given coordinate system.
;;;
;;;         See the AutoCAD reference manual for details.

(defun nc:arbaxis (n)
  (setq wy (list 0.0 1.0 0.0)
        wz (list 0.0 0.0 1.0)
  )
  (if (and (< (abs (car n)) (/ 1.0 64.0))
           (< (abs (cadr n)) (/ 1.0 64.0))
      )
      (setq ax (nc:crossp wy n))
      (setq ax (nc:crossp wz n))
  )
  (setq ay (nc:crossp n ax))
  (list ax ay)
)


;;; NC:XPOLY -- Polylines not contained within blocks.
;;;
;;;         To make NCOPY more useful and friendly, the command will
;;;         (entmake) the selected entity even if the selected entity
;;;         is not contained within a block.  However, for polylines,
;;;         (nentsel) always returns a VERTEX entity.  This function
;;;         steps through the vertices and finds the polyline header
;;;         so that the polyline may be created.

(defun nc:xpoly (e / pt pn ph phd pv pvt)
  (setq pt (cdr (assoc 0 e))
        pn (cdr (assoc -1 e))
  )
  (while (/= pt "SEQEND")
    (setq ph (entget (entnext pn))
          pt (cdr (assoc 0 ph))
          pn (cdr (assoc -1 ph))
    )
  )  
  (setq phd (entget (cdr (assoc -2 ph))))
  (entmake (cdr phd))
  (setq pv (entget (entnext (cdr (assoc -1 phd))))
        pvt (cdr (assoc 0 pv))
  )
  (while (/= pvt "SEQEND")
    (entmake (cdr pv))
    (setq pv (entget (entnext (cdr (assoc -1 pv))))
          pvt (cdr (assoc 0 pv))
    )
  )
  (entmake (cdr pv))
)


;;; NC:ALLBLK -- Copy all entities at same block nesting level.
;;;
;;;        If the command C:NCOPYSET is used to set the All option,
;;;        then all of the entities in the same block reference as the
;;;        selected entity will also be copied.  The resulting entities
;;;        are added to the selection set NC:SSET.  This selection set
;;;        is cleared each time the C:NCOPY command is issued.

(defun nc:allblk ( / ab1 ab2 ab3 ab4 ab5 abphold abptype abpname)
  (setq ab1 (nth 0 (nth 3 nc:a))
        ab2 (entget ab1)
        ab3 (tblsearch "BLOCK" (cdr (assoc 2 ab2)))
        ab4 (entget (cdr (assoc -2 ab3)))
  )
  (princ (strcat "\nMaking all entities in block " (cdr (assoc 2 ab2)) ". "))
  (nc:gettype ab4)
  (setq nc:sset (ssadd (entlast)))
  (if (= (cdr (assoc 0 ab4)) "POLYLINE")
    (progn
      (setq abphold ab4
            abptype (cdr (assoc 0 abphold))
            abpname (cdr (assoc -1 abphold))
      )
      (while (/= abptype "SEQEND")
        (setq abphold (entget (entnext abpname))
              abptype (cdr (assoc 0 abphold))
              abpname (cdr (assoc -1 abphold))
        )
      )
      (setq ab4 abphold)
    )
  )
  (while (setq ab5 (entnext (cdr (assoc -1 ab4))))
    (setq nc:paflag T
          nc:pwflag T
          ab4 (entget ab5)
    )
    (if (= (cdr (assoc 0 ab4)) "POLYLINE")
      (progn
        (setq abphold ab4
              abptype (cdr (assoc 0 abphold))
              abpname (cdr (assoc -1 abphold))
        )
        (while (/= abptype "SEQEND")
          (setq abphold (entget (entnext abpname))
                abptype (cdr (assoc 0 abphold))
                abpname (cdr (assoc -1 abphold))
          )
        )
        (setq ab4 abphold)
      )
    )
    (nc:gettype ab4)
    (setq nc:sset (ssadd (entlast) nc:sset))
  )
)


;;; NC:GETTYPE -- Determine entity type and call appropriate function.

(defun nc:gettype (e / e0)
  (setq e0 (cdr (assoc 0 e)))
  (cond ((= e0 "LINE")
         (nc:line e)
        )
        ((= e0 "CIRCLE")
         (nc:circle e)
        )
        ((= e0 "ARC")
         (nc:arc e)
        )
        ((= e0 "POINT")
         (nc:point e)
        )
        ((= e0 "TRACE")
         (nc:trace e)
        )
        ((= e0 "SOLID")
         (nc:trace e)
        )
        ((= e0 "3DFACE")
         (nc:3df e)
        )
        ((= e0 "TEXT")
         (nc:text e)
        )
        ((= e0 "ATTDEF")
         (nc:text e)
        )
        ((= e0 "ATTRIB")
         (nc:text e)
        )
        ((= e0 "VERTEX")
         (nc:poly e)
        )
        ((= e0 "POLYLINE")
         (nc:poly e)
        )
        ((= e0 "SEQEND")
         (nc:poly e)
        )
        ((= e0 "INSERT")
         (nc:insert e)
        )
        (T
         (princ (strcat "\n" e0 " is an unsupported entity type. "))
         (princ)
        )
  )
)


;;; NC:BLKINFO -- BLocK INFOrmation.
;;;
;;;         Gather up total scale factors, block rotations and
;;;         normals from all blocks in nesting structure.  The
;;;         data used by other functions are assigned to globals.

(defun nc:blkinfo (blklst / blen c1 b1 b210a)
  (setq blen      (length blklst)
        c1        0
        nc:bx     1.0
        nc:by     1.0
        nc:bz     1.0
        nc:blkrot 0.0
        nc:b210   (list 0.0 0.0 0.0)
  )
  (while (< c1 blen)
    (setq b1        (entget (nth c1 blklst))
          b210a     (cdr (assoc 210 b1))
          nc:bx     (* nc:bx (cdr (assoc 41 b1)))
          nc:by     (* nc:by (cdr (assoc 42 b1)))
          nc:bz     (* nc:bz (cdr (assoc 43 b1)))
          nc:blkrot (+ nc:blkrot (cdr (assoc 50 b1)))
          b210a     (cdr (assoc 210 b1))
          nc:b210   (list (+ (car nc:b210) (car b210a))
                          (+ (cadr nc:b210) (cadr b210a))
                          (+ (caddr nc:b210) (caddr b210a))
                    )
          c1        (1+ c1)
    )
  )
  (if (equal nc:b210 '(0.0 0.0 0.0) 1e-10)
    (setq nc:b210 b210a)
  )
  (setq nc:b210 (nc:univ nc:b210))
  (if (= (abs nc:bx) (abs nc:by) (abs nc:bz))
    (setq nc:allsfeq T)
    (setq nc:allsfeq nil)
  )
)


;;;  NC:NO_OP -- No OPeration.
;;;
;;;         This function is called if an entity is selected that is
;;;         not contained within a block.  It can be redefined to
;;;         perform whatever operation is deemed appropriate if a non-
;;;         block entity is selected.  This definition goes ahead and
;;;         creates a new entity identical to the selected entity.  If
;;;         no copy is desired, un-comment the alternate function below.

(defun nc:no_op ( / nx1)
  (setq nx1 (entget (car a)))
  (if (/= (cdr (assoc 0 nx1)) "VERTEX")
    (entmake (cdr nx1))
    (nc:xpoly nx1)
  )
)

;;; (defun nc:no_op ()
;;;   (princ "\nSelected entity is not contained within a block.")
;;; )


;;; NC:NEWERR -- Redefined error function to prevent lisp traceback.

(defun nc:newerr (msg)
  (princ (strcat "\nError: " msg))
  (setq *error*   nc:olderr
        nc:bx     nil nc:by     nil nc:bz      nil
        nc:blkrot nil nc:b210   nil nc:allsfeq nil
        nc:tflag  nil nc:pwflag nil nc:paflag  nil
        nc:olderr nil
  )
  (princ)
)


;;;  C:NCOPYSET -- Set NCOPY option.
;;;
;;;        If the global nc:wholeblk is T, then all of the entities found
;;;        within the same block definition as the selected entity will also
;;;        be copied as if they were selected individually.  If using this
;;;        option, nested block references (INSERT entities) will also be
;;;        copied (block references cannot be selected by picking).  The
;;;        group of entities are gathered into a selection set called NC:SSET.

(defun C:NCOPYSET ( / ncs1 ncs2)
  (setq nc:olderr *error*
        *error* nc:newerr
  )
  (if nc:wholeblk
    (setq ncs1 "All")
    (setq ncs1 "Single")
  )
  (initget "All Single")
  (setq ncs2
        (getkword
          (strcat "\nNCOPY Single entity or All entities in block? (S/A) <"
                  ncs1
                  ">: "
          )
        )
  )
  (if (= ncs2 nil)
    (setq ncs2 ncs1)
  )
  (if (= ncs2 "All")
    (progn
      (setq nc:wholeblk T
            nc:wbprompt "\nNCOPY all entities in block.  Select object:"
      )
      (princ "\nNCOPY will copy ALL entities in block at same nesting level.")
      (princ)
    )
    (progn
      (setq nc:wholeblk nil
            nc:wbprompt "\NCOPY only the selected entity.  Select object:"
      )
      (princ "\nNCOPY will copy only the selected entity.")
      (princ)
    )
  )
  (setq *error* nc:olderr
        nc:olderr nil
  )
  (princ)
)


;;; C:NCOPY -- Nested entity COPY command.
;;;
;;;         This main function captures and resets the *error*
;;;         function to prevent display of the lisp traceback.
;;;         It also sets the message flags, issues the actual
;;;         nentsel function, determines if the selected entity
;;;         is within a block and calls the appropriate function.
;;;         Upon exit, all globals are reset to nil.

(defun C:NCOPY ( / nc:a nc:e matrix nc:olderr)
  (setq nc:olderr *error*
        *error*   nc:newerr
  )
  (if (not nc:wbprompt)
    (setq nc:wbprompt "\NCOPY only the selected entity.  Select object:")
  )
  (setq nc:allsfeq  nil
        nc:tflag    T
        nc:pwflag   T
        nc:paflag   T
        nc:sset     nil
        nc:a        (nentsel nc:wbprompt)
        nc:e        (entget (car nc:a))
  )
  (if (= 4 (length nc:a))
    (progn
      (setq matrix (caddr nc:a))
      (nc:blkinfo (nth 3 nc:a))
      (if nc:wholeblk
        (nc:allblk)
        (nc:gettype nc:e)
      )
    )
    (nc:no_op)
  )
  (setq nc:bx     nil nc:by     nil nc:bz      nil
        nc:blkrot nil nc:b210   nil nc:allsfeq nil
        nc:tflag  nil nc:pwflag nil nc:paflag  nil
        *error*   nc:olderr     nc:olderr      nil
  )
  (princ)
)

(princ "\nC:NCOPY loaded.  Enter NCOPY to use, or NCOPYSET to set options.")
(princ)

alin

Pay attention to this function
NC:XFORM -- TransFORM a point from the MCS to WCS.

jxphklibin

我已经贴在这里了，自己进去看吧：

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=74640