[编程交流] 我的一些lisp编码。。。

(vl-load-com)
(defun sslist  (ss / n lst)
 (if (= (type ss) 'pickset)
   (repeat (setq n (ssLength ss))
     (setq n (1- n)
    lst (cons (ssname ss n) lst)))))
(defun coolineal  (p1 p2 ptchk / ang ang1 absang fuzz)
 (setq fuzz 0.00001)
 (if (or (equal p1 ptchk fuzz) (equal p2 ptchk fuzz))
   (setq retval t)
   (progn
     (setq ang    (angle p1 ptchk)
    ang1   (angle p1 p2)
    absang (abs (- ang ang1)))
     (if (or (equal absang 0.0 fuzz)
      (equal absang pi fuzz)
      (equal absang (* pi 2) fuzz))
t
nil))))
(defun lincool (l1 l2 / p1 p2 p3 p4)
 (setq p1 (cdr (assoc 10 (entget l1)))
p2 (cdr (assoc 11 (entget l1)))
p3 (cdr (assoc 10 (entget l2)))
p4 (cdr (assoc 11 (entget l2))))
 (if (and (coolineal p1 p2 p3) (coolineal p1 p2 p4))
   t))
(if (not thisdwg)
 (setq thisdwg (vla-get-activedocument (vlax-get-acad-object))))
(if (not modelspace)
 (setq modelspace
 (vla-get-modelspace thisdwg)))
(defun paperspace () (vla-get-paperspace thisdwg))
(defun rcmd-get-activespace  ()
 (if (= acmodelspace (vla-get-activespace thisdwg))
   modelspace
   (if (= (vla-get-mspace thisdwg) :vlax-true)
     modelspace
     (paperspace))))
(defun adddimrotated
       (xline1point xline2point dimlinelocation rotationangle / vla_dim)
 (if (not (vl-catch-all-error-p
     (setq vla_dim
     (vl-catch-all-apply
       'vla-adddimrotated
       (list (rcmd-get-activespace)
      (vlax-3d-point xline1point)
      (vlax-3d-point xline2point)
      (vlax-3d-point dimlinelocation)
      rotationangle)))))
   vla_dim))
(defun arrowhead-blk  (bname)
 (cond
   ((= bname "_DOT")
    acArrowDot)
   ((= bname "_DOTSMALL")
    acArrowDotSmall)
   ((= bname "_DOTBLANK")
    acArrowDotBlank)
   ((= bname "_ORIGIN")
    acArrowOrigin)
   ((= bname "_ORIGIN2")
    acArrowOrigin2)
   ((= bname "_OPEN")
    acArrowOpen)
   ((= bname "_OPEN90")
    acArrowOpen90)
   ((= bname "_OPEN30")
    acArrowOpen30)
   ((= bname "_CLOSED")
    acArrowClosed)
   ((= bname "_SMALL")
    acArrowSmall)
   ((= bname "_NONE")
    acArrowNone)
   ((= bname "_OBLIQUE")
    acArrowOblique)
   ((= bname "_BOXFILLED")
    acArrowBoxFilled)
   ((= bname "_BOXBLANK")
    acArrowBoxBlank)
   ((= bname "_CLOSEDBLANK")
    acArrowClosedBlank)
   ((= bname "_DATUMFILLED")
    acArrowDatumFilled)
   ((= bname "_DATUMBLANK")
    acArrowDatumBlank)
   ((= bname "_INTEGRAL")
    acArrowIntegral)
   ((= bname "_ARCHTICK")
    acArrowArchTick)))
(defun C:REDODIM  (/ ss lst lst_lines lst_blocks lst_solids ints int1 int2 int3 line1 line2
    line3 lst3)
 (if (setq ss (ssget))
   (progn
     (setq lst       (sslist ss)
    lst_lines
       (vl-remove-if-not
  (function (lambda (ent) (eq (cdadr (entget ent)) "LINE")))
  lst))
     (if (not
    (setq lst_blocks
    (vl-remove-if-not
      (function
        (lambda (ent) (eq (cdadr (entget ent)) "INSERT")))
      lst)))
(setq lst_solids
       (vl-remove-if-not
  (function
    (lambda (ent) (eq (cdadr (entget ent)) "SOLID")))
  lst)))
     (setq l_a     lst_lines
    L_a2    l_a
    lTemp   T
    lTot    nil
    lst_not
     nil
    par     nil)
     (while l_a2
(setq EntChk (car l_a2)
      l_a2   (cdr l_a2))
(setq list_T-nil
       (mapcar (function (lambda (x) (lincool x EntChk))) l_a2))
(setq lTemp (vl-remove-if
       'not
       (mapcar (function
   (lambda (x y)
     (if (and x y)
       y)))
        list_T-nil
        l_a2)))
(foreach j lTemp (setq l_a2 (vl-remove j l_a2)))
(setq lTemp (cons EntChk lTemp))
(if (and lTemp (> (length lTemp) 1))
  (setq lTot (cons lTemp lTot))
  (setq lst_not (cons ltemp lst_not))))
     (setq tmp nil)
     (if (and (not ltot) lst_not (= (length lst_not) 3))
(progn
  (setq lst3  (apply 'append lst_not)
 line1 (car lst3)
 line2 (cadr lst3)
 line3 (caddr lst3)
 p1    (cdr (assoc 10 (entget line1)))
 p2    (cdr (assoc 11 (entget line1)))
 p3    (cdr (assoc 10 (entget line2)))
 p4    (cdr (assoc 11 (entget line2)))
 p5    (cdr (assoc 10 (entget line3)))
 p6    (cdr (assoc 11 (entget line3)))
 int1  (inters p1 p2 p3 p4 nil)
 int2  (inters p3 p4 p5 p6 nil)
 int3  (inters p1 p2 p5 p6 nil)
 ints  (vl-remove nil (list int1 int2 int3))
 a     (car ints)
 b     (cadr ints)
 flag  (if lst_blocks
  "insert"
  "solid"))
  (cond
    ((= flag "solid")
     (setq solid1  (car lst_solids)
    elst    (entget solid1)
    p1    (cdr (assoc 10 elst))
    p2    (cdr (assoc 11 elst))
    p3    (cdr (assoc 12 elst))
    solid2  (cadr lst_solids)
    elst    (entget solid2)
    p1    (cdr (assoc 10 elst))
    p2    (cdr (assoc 11 elst))
    p4    (cdr (assoc 12 elst))
    c    p3
    dim_obj
     (adddimrotated a b c (angle p3 p4)))
     (vla-put-arrowhead1type dim_obj acarrowdefault)
     (vla-put-arrowhead2type dim_obj acarrowdefault))
    ((= flag "insert")
     (setq block1  (car lst_blocks)
    elst    (entget block1)
    bname   (cdr (assoc 2 (entget block1)))
    p3    (cdr (assoc 10 (entget block1)))
    block2  (cadr lst_blocks)
    elst    (entget block2)
    p4    (cdr (assoc 10 (entget block2)))
    c    p3
    dim_obj
     (adddimrotated a b c (angle p3 p4)))
     (vla-put-arrowhead1type
       dim_obj
       (arrowhead-blk (strcase bname)))
     (vla-put-arrowhead2type
       dim_obj
       (arrowhead-blk (strcase bname)))))))
     (if ltot
(progn
  (setq i 0)
  (repeat (length (setq par (car ltot)))
    (setq ename (nth i par)
   tmp (cons (cdr (assoc 10 (entget ename))) tmp)
   tmp (cons (cdr (assoc 11 (entget ename))) tmp)
   i (1+ i)))
  (setq flag (if lst_blocks
        "insert"
        "solid"))
  (cond
    ((= flag "solid")
     (setq solid1  (car lst_solids)
    elst    (entget solid1)
    p1    (cdr (assoc 10 elst))
    p2    (cdr (assoc 11 elst))
    p3    (cdr (assoc 12 elst))
    solid2  (cadr lst_solids)
    elst    (entget solid2)
    p1    (cdr (assoc 10 elst))
    p2    (cdr (assoc 11 elst))
    p4    (cdr (assoc 12 elst))
    par    (apply 'append lst_not)
    a    (cdr (assoc 10 (entget (car par))))
    b    (cdr (assoc 10 (entget (cadr par))))
    c    p3
    dim_obj
     (adddimrotated a b c (angle p3 p4)))
     (vla-put-arrowhead1type dim_obj acarrowdefault)
     (vla-put-arrowhead2type dim_obj acarrowdefault))
    ((= flag "insert")
     (setq block1  (car lst_blocks)
    elst    (entget block1)
    bname   (cdr (assoc 2 (entget block1)))
    p3    (cdr (assoc 10 (entget block1)))
    block2  (cadr lst_blocks)
    elst    (entget block2)
    p4    (cdr (assoc 10 (entget block2)))
    par    (apply 'append lst_not)
    a    (cdr (assoc 10 (entget (car par))))
    b    (cdr (assoc 10 (entget (cadr par))))
    c    p3
    dim_obj
     (adddimrotated a b c (angle p3 p4)))
     (vla-put-arrowhead1type
       dim_obj
       (arrowhead-blk (strcase bname)))
     (vla-put-arrowhead2type
       dim_obj
       (arrowhead-blk (strcase bname)))))))
     (if dim_obj
(mapcar 'entdel lst))))
 (princ))
(princ)

;; by LE
;; To turn this ability ON-OFF use:
;; For ON:
;; (setenv "AutoAreaReader" "1")
;; For OFF:
;; (setenv "AutoAreaReader" "0")
;;
;;
;; To change the print output use:
;; Variable name: def_show_area 
;; Options: 
;; 1. "Decimal"
;; 2. "Squarefeet"
;; 3. "Acres"
;; 4. "SquareMeters"
;; 5. "Hectares"
;; In example: 
;; Command: (setq def_show_area "Acres")
;;--------------------------------------------------------------
(if (not (getenv "AutoAreaReader"))
 (setenv "AutoAreaReader" "0"))
;;--------------------------------------------------------------
(defun ssget->vla-list  (ss / index vlaList)
 (setq index (if ss
 (1- (ssLength ss))
 -1))
 (while (>= index 0)
   (setq vlaList (cons
     (vlax-ename->vla-object
       (ssname ss index))
     vlaList)
  index   (1- index)))
 vlaList)
;;--------------------------------------------------------------
(defun addComma  (txt / strl cont1 lth cont txt1)
 (setq strl  (strlen txt)
cont1 1
txt1  "")
 (while (and (/= (substr txt cont1 1) ".") (<= cont1 strl))
   (setq cont1 (1+ cont1)))
 (setq lth   (1- cont1)
cont1 1
cont  (1- lth))
 (if (> lth 3)
   (progn
     (while (< cont1 lth)
(setq let  (substr txt cont1 1)
      txt1 (strcat txt1 let))
(if (and (zerop (rem cont 3)) (eq (type (read let)) 'INT))
  (setq txt1 (strcat txt1 ",")))
(setq cont  (1- cont)
      cont1 (1+ cont1)))
     (while (<= cont1 strl)
(setq txt1  (strcat txt1 (substr txt cont1 1))
      cont1 (1+ cont1)))
     txt1)
   txt))
;;--------------------------------------------------------------
(defun printArea  (ar / string)
 (setq string
   "\nChange variable LUPREC to a higher precision value - try again.")
 (if (not def_show_area)
   (setq def_show_area "Decimal"))
 (cond
   ((= def_show_area "Decimal")
    (if (zerop (atof (rtos ar 2 (getvar "luprec"))))
      (prompt string)
      (princ
 (addComma
   (rtos ar 2 (getvar "luprec"))))))
   ((= def_show_area "Squarefeet")
    (if (zerop (atof (rtos (/ ar 144.0) 2 (getvar "luprec"))))
      (prompt string)
      (progn
 (princ
   (addComma (rtos (/ ar 144.0) 2 (getvar "luprec"))))
 (princ " square feet"))))
   ((= def_show_area "Acres")
    (if
      (zerop
 (atof (rtos (/ (/ ar 144.0) 43560.0) 2 (getvar "luprec"))))
(prompt string)
(progn
  (princ
    (addComma
      (rtos (/ (/ ar 144.0) 43560.0) 2 (getvar "luprec"))))
  (princ " acres"))))
   ((= def_show_area "SquareMeters")
    (if (zerop (atof (rtos ar 2 (getvar "luprec"))))
      (prompt string)
      (progn
 (princ
   (addComma
     (rtos ar 2 (getvar "luprec"))))
 (princ " m2"))))
   ((= def_show_area "Hectares")
    (if
      (zerop
 (atof (rtos (/ ar 10000.0) 2 (getvar "luprec"))))
(prompt string)
(progn
  (princ
    (addComma
      (rtos (/ ar 10000.0) 2 (getvar "luprec"))))
  (princ " hectares"))))))
;;--------------------------------------------------------------
(defun areareader-pickfirst
      (reactor params / ss ent obj ar pol_data lst_dat)
 (if (eq (getenv "AutoAreaReader") "1")
   (cond
     ((and (eq 1 (logand 1 (getvar "pickfirst")))
    (setq ss (ssget "_i" '((0 . "LWPOLYLINE"))))
    (eq 1 (sslength ss))
    (setq ent (ssname ss 0))
    (setq obj (vlax-ename->vla-object ent))
    (eq (vla-get-closed obj) :vlax-true))
      (setq ar (vla-get-area obj))
      (princ "\nArea of single polyline= ")
      (printArea ar)
      (princ))
     ((and
 (eq 1 (logand 1 (getvar "pickfirst")))
 (setq ss (ssget "_i" '((0 . "LWPOLYLINE"))))
 (> (sslength ss) 1)
 (vl-every
   (function
     (lambda (obj) (eq (vla-get-closed obj) :vlax-true)))
   (setq objs (ssget->vla-list ss))))
      (princ "\nTotal area of multiple polylines= ")
      (setq ar (apply '+ (mapcar 'vla-get-area objs)))
      (printArea ar)
      (princ)))))
;;--------------------------------------------------------------
(if (not areareader_pickfirst_reactor)
 (setq areareader_pickfirst_reactor
 (vlr-set-notification
   (vlr-miscellaneous-reactor
     "AutoAreaReader"
     '((:vlr-pickfirstmodified . areareader-pickfirst)))
   'active-document-only)))
;;--------------------------------------------------------------
(defun dtt-removeall  (reactor params)
 (vlr-remove-all))
;;--------------------------------------------------------------
(if (not dtt_reactor_dwg)
 (setq dtt_reactor_dwg
 (vlr-set-notification
   (vlr-editor-reactor
     "removeallreactors"
     '((:vlr-beginclose . dtt-removeall)))
   'active-document-only)))
;;--------------------------------------------------------------
(defun C:AR()
(cond
 ;; ON
 ((and (eq (getenv "AutoAreaReader") "1")
areareader_pickfirst_reactor
(not (vlr-added-p areareader_pickfirst_reactor)))
  (vlr-add areareader_pickfirst_reactor))
 ;; OFF
 ((and (eq (getenv "AutoAreaReader") "0")
areareader_pickfirst_reactor
(vlr-added-p areareader_pickfirst_reactor))
  (vlr-remove areareader_pickfirst_reactor)))
 (princ))
(princ)

;; by LE
(if (not thisDwg)
 (setq thisDwg
(vla-get-activeDocument (vlax-get-acad-object))))
(defun pspace () (vla-get-paperSpace thisDwg))
(if (not :rcmModel)
 (setq :rcmModel
(vla-get-modelSpace thisDwg)))
(defun activespace  ()
 (if (= acModelSpace (vla-get-activeSpace thisDwg))
   :rcmModel
   (if (= (vla-get-mSpace thisDwg) :vlax-true)
     :rcmModel
     (pspace))))
(defun list->variantArray  (ptslist / arrayspace sarray)
 (setq arrayspace
(vlax-make-safeArray
   vlax-vbDouble
   (cons 0
 (- (length ptslist) 1))))
 (setq sarray (vlax-safeArray-fill arrayspace ptslist))
 (vlax-make-variant sarray))
(defun getbulge (fromVertex midp p2 / ang chord midc alt)
 (setq ang   (angle fromVertex p2)
chord (distance fromVertex p2)
midc  (polar fromVertex ang (* chord 0.5))
alt   (distance midp midc))
 (cond
   ((zerop chord) 0.0)
   ((equal (angle midp midc)
    (rem (+ ang (* pi 0.5)) (* pi 2))
    1e-4)
    (/ alt chord 0.5))
   (T (/ alt chord -0.5))))
(defun 2dpt  (pt)
 (if (caddr pt)
   (list (car pt) (cadr pt))
   pt))
(defun pline_vlisp  (tst / sp pts index vla_poly)
 (setq sp (2dpt (caar tst)))
   (setq
   pts (mapcar
  (function (lambda (lst)
       (cond
  ((= (length lst) 2) (2dpt (cadr lst)))
  ((= (length lst) 3) (2dpt (caddr lst))))))
  tst))
 (setq pts (cons sp pts))
 (if (not (vl-catch-all-error-p
     (setq vla_poly
     (vl-catch-all-apply
       'vla-addlightweightpolyline
       (list (activespace)
      (list->variantArray (apply 'append pts)))))))
   (vla-put-closed vla_poly t))
 (setq index 0)
 (mapcar (function
    (lambda (lst)
      (if (= (length lst) 3)
 (vla-setbulge
   vla_poly
   index
   (getbulge (car lst) (cadr lst) (caddr lst))))
      (setq index (1+ index))))
  tst)
 vla_poly)
;; list of points
;; included are lists of two for lines and three for curves
(setq tst (list
    '((39.6076 -8.96248 0.0) (32.6084 -18.2036 0.0))
    '((32.6084 -18.2036 0.0) (52.2729 -16.9548))
    '((52.2729 -16.9548)
      (56.9734 -18.4078)
      (59.5221 -22.6161))
    '((59.5221 -22.6161)
      (64.61 -25.6477)
      (66.938 -20.2017))
    '((66.938 -20.2017) (59.0222 -7.79693 0.0))
    '((59.0222 -7.79693 0.0) (39.6076 -8.96248 0.0))))
;; do the test...
;;(pline_vlisp tst) ;; remove this line to test the above code

(vl-load-com)
(if (not (vl-file-directory-p "C:\\AUTOSAVE\"))
 (vl-mkdir "C:\\AUTOSAVE\"))
(defun copy_sv$  (reactor params / files file)
 (if
   (and (setq files
 (vl-directory-files (getvar "SAVEFILEPATH") "*.SV$"))
 (setq file
 (vl-some
   (function
     (lambda (dwg)
       (if
  (wcmatch
    dwg
    (strcat "*"
     (vl-filename-base (getvar "DWGNAME"))
     "*"))
   dwg)))
   files)))
    (progn
      ;; make a copy of SV$ file into the c:\\autosave folder
      ;; as a drawing extension with the OUT_ prefix
      (vl-file-copy
 (strcat (getvar "SAVEFILEPATH") "\" file)
 (strcat "C:\\AUTOSAVE\" "OUT_" (getvar "DWGNAME")))
      ;; delete previous BAK_ file
      (vl-file-delete
 (strcat "C:\\AUTOSAVE\" "BAK_" (getvar "DWGNAME")))
      ;; rename the new OUT_ file with the BAK_ prefix
      (vl-file-rename
 (strcat "C:\\AUTOSAVE\" "OUT_" (getvar "DWGNAME"))
 (strcat "C:\\AUTOSAVE\" "BAK_" (getvar "DWGNAME")))
      ;; delete OUT_ file
      (vl-file-delete
 (strcat "C:\\AUTOSAVE\" "OUT_" (getvar "DWGNAME"))))))
(if (not dwg_reactor)
 (setq dwg_reactor
 (vlr-dwg-reactor nil '((:vlr-beginsave . copy_sv$)))))
(princ)

;;LE
;; degrees
(setq :rwiz_45degrees (* pi 0.25))
(setq :rwiz_90degrees (* pi 0.5))
(setq :rwiz_135degrees (* pi 0.75))
(setq :rwiz_225degrees (* pi 1.25))
(setq :rwiz_270degrees (* pi 1.5))
(setq :rwiz_315degrees (* pi 1.75))
(setq :rwiz_360degrees (* pi 2.0))
;;;_____________________________________________________________
;; get acad object object
;; LE
(if (not :rwiz_acad)
   (setq :rwiz_acad (vlax-get-acad-object)))
;;;_____________________________________________________________
;;; get active drawing object
;;; LE
(defun rwiz-thisdwg () (vla-get-activedocument :rwiz_acad))
;; global variable for this drawing
;; LE
;;;(or :rwiz_thisdwg (setq :rwiz_thisdwg (rwiz-thisdwg)))
(setq
 :rwiz_thisdwg
  (cond (:rwiz_thisdwg)
 ((rwiz-thisdwg))
 (t (rwiz-thisdwg))))
;;;_____________________________________________________________
;; get model space object
;; LE
(if (not :rwiz_model)
   (setq :rwiz_model
   (vla-get-modelspace (rwiz-thisdwg))))
;;;_____________________________________________________________
;;; get paper space object
;;; LE
(defun rwiz-pspace () (vla-get-paperspace (rwiz-thisdwg)))
;;;_____________________________________________________________
;;; get active space object
(defun rwiz-get-activespace  ()
 (if (= acmodelspace (vla-get-activespace (rwiz-thisdwg)))
   :rwiz_model
   (if (= (vla-get-mspace (rwiz-thisdwg)) :vlax-true)
     :rwiz_model
     (rwiz-pspace))))
;;;_____________________________________________________________
;;; get active space name "Model" or "Paper"
(defun rwiz-activespacename  ()
 (cond
   ((= acmodelspace (vla-get-activespace (rwiz-thisdwg)))
    "Model")
   (t
    (if (= (vla-get-mspace (rwiz-thisdwg)) :vlax-true)
      "Model"
      "Paper"))))
;;;_____________________________________________________________
;;; adjust dimscale, it will use 1.0 factor when is in paper space
;;; sc = scale factor as real
;;; LE
(defun rwiz-adjust-dimscale  (sc)
 (if (= (rwiz-activespacename) "Model")
   sc
   1.0))
;;;_____________________________________________________________
;;; list to variant array
;;; ptslist = point list
(defun rwiz-list-variantarray  (ptslist / arrayspace sarray)
 (setq arrayspace
 (vlax-make-safearray
   ;; element type
   vlax-vbdouble
   ;; array dimension
   (cons 0
  (- (length ptslist) 1))))
 (setq sarray (vlax-safearray-fill arrayspace ptslist))
 ;; return array variant
 (vlax-make-variant sarray))
;;;_____________________________________________________________
;;; 3d point to 2d point
;;; 3dpt = 3d point
(defun rwiz-3dpt-2dpt  (3dpt)
 (list (float (car 3dpt)) (float (cadr 3dpt))))
;;;_____________________________________________________________
;;; selection set to vla objects list
;;; ss = selection set
(defun rwiz-ss-vla-list  (ss / index vlalist)
 (setq index (if ss
 (1- (sslength ss))
 -1))
 (while (>= index 0)
   (setq vlalist (cons
     (vlax-ename->vla-object
       (ssname ss index))
     vlalist)
  index   (1- index)))
 vlalist)
;;;_____________________________________________________________
;;; selection set to array
;;; ss = selection set
(defun rwiz-ss-array  (ss / c r)
 (setq c -1)
 (repeat (sslength ss)
   (setq r (cons (ssname ss (setq c (1+ c))) r)))
 (setq r (reverse r))
 (vlax-safearray-fill
   (vlax-make-safearray
     vlax-vbobject
     (cons 0 (1- (length r))))
   (mapcar 'vlax-ename->vla-object r)))
;;;_____________________________________________________________
;;; array of vbobject's
;;; vla_lst = vla-object list
;;; LE
(defun rwiz-array-vbobject  (vla_lst)
 (vlax-safearray-fill
   (vlax-make-safearray
     vlax-vbobject
     (cons 0 (1- (length vla_lst))))
   vla_lst))
;;;_____________________________________________________________
;;; make block
;;; usage:
;;; (rwiz-makeblock (list 0.0 0.0 0.0) "BLOCKNAME" selection_set T)
;;; flag:
;;; t = delete objects
;;; nil = keep objects
;;; LE
(defun rwiz-makeblock  (pt name ss flag / ssarray vla_block)
 (vla-copyobjects
   (rwiz-thisdwg)
   (setq ssarray (rwiz-ss-array ss))
   (setq vla_block (vla-add (vla-get-blocks (rwiz-thisdwg))
       (vlax-3d-point pt)
       name)))
 ;; delete objects
 (if (and flag
   ssarray
   (= (type ssarray) 'safearray)
   ;; is the safearray made of vlax-object's
   (= (vlax-safearray-type ssarray) 9))
   (mapcar 'vla-delete (safearray-value ssarray)))
 vla_block)
;;;_____________________________________________________________

copy

...
 (cond
   ((and (equal (vlr-type reactor) :vlr-object-reactor)
  (vl-some 'vlax-erased-p (vlr-owners reactor)))
    (foreach owner  (vlr-owners reactor)
      (vlr-owner-remove reactor owner))
    (vlr-data-set reactor nil)
    (vlr-pers-release reactor))
   ((and (equal (vlr-type reactor) :vlr-object-reactor)
  (not (vlr-owners reactor)))
    (foreach owner  (vlr-owners reactor)
      (vlr-owner-remove reactor owner))
    (vlr-data-set reactor nil)
    (vlr-pers-release reactor))
   ((and (vlr-added-p reactor)
  (not (equal (vlr-type reactor)
       :vlr-object-reactor))
  (vl-some 'vlax-erased-p (vlr-data reactor)))
    (vlr-data-set reactor nil)
    (vlr-pers-release reactor))
   ((and (vlr-added-p reactor)
  (not (equal (vlr-type reactor)
       :vlr-object-reactor))
  (not (vlr-data reactor)))
    (vlr-data-set reactor nil)
    (vlr-pers-release reactor))))
;;;_____________________________________________________________
(defun rwiz-update-pers-list  ()
 (mapcar
   (function
     (lambda (reactor)
(cond
  ((and (equal (vlr-type reactor) :vlr-object-reactor)
 (vl-some 'vlax-erased-p (vlr-owners reactor)))
   (foreach owner  (vlr-owners reactor)
     (vlr-owner-remove reactor owner))
   (vlr-data-set reactor nil)
   (vlr-pers-release reactor))
  ((and (equal (vlr-type reactor) :vlr-object-reactor)
 (not (vlr-owners reactor)))
   (foreach owner  (vlr-owners reactor)
     (vlr-owner-remove reactor owner))
   (vlr-data-set reactor nil)
   (vlr-pers-release reactor))
  ((and (vlr-added-p reactor)
 (not (equal (vlr-type reactor)
      :vlr-object-reactor))
 (vl-some 'vlax-erased-p (vlr-data reactor)))
   (vlr-data-set reactor nil)
   (vlr-pers-release reactor))
  ((and (vlr-added-p reactor)
 (not (equal (vlr-type reactor)
      :vlr-object-reactor))
...

反应器Wiz。拉链

(vl-load-com)
(defun C:LCOPY (/      p1     p2     p3     p4    sep   lcopyent
 entlist       m      s     n    c   lst
 obj  take   code5  mklin     
       )  
;;;      (lbx-sysvarbegin
;;; '("cursorsize" "snapang" "orthomode")
;;;      )
;;; global symbol for angle direction
     (if (not atemp)
(setq atemp 0.0)
     )
;;; preset distance separation
     (if (not ll)
(setq ll 1.0)
     )
;;; just in case delete list of points
     (file2nil)
     (setq lst nil)
     (prompt
"\nLine Copier - inside this view only "
     )
     (setq mklin (vector))
     (if (= mklin nil)
(setq obj (entsel "\nSelect: "))
(progn (setq p1 (car mklin)) (setq p2 (cadr mklin)))
     )
     (if (and obj (= (cdr (assoc 0 (entget (car obj)))) "LINE"))
(progn
  (setq lcopyent (car obj))
;;;   (redraw lcopyent 3)
  (setq
    entlist (entget lcopyent)
    p1     (cdr (assoc 10 entlist))
    p2     (cdr (assoc 11 entlist))
  )
)
     )
     (setq lst (readfile))
     (if (and p1 p2)
(progn
  (if (and (not (member (point2str p1) lst))
    (not (member (point2str p2) lst))
      )
    (entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
  )
  (if (not (member (point2str p1) lst))
    (write2file (point2str p1))
  )
  (if (not (member (point2str p2) lst))
    (write2file (point2str p2))
  )
  (setq lst (readfile))
)
     )
     (if p1
(progn
  (setvar "orthomode" 0)
  (initget 6)
  (setq sep
  (getdist
    (strcat "\nSelect two points/<Offset distance = "
     (rtos ll)
     ">: "
    )
  )
  )
  (if (= sep nil)
    (setq sep ll)
  )
  (if (not ll)
    (setq ll 1.0)
  )
  (setq ll sep)
)
     )
     (if (and p1 p2 sep)
(progn
  (prompt
    "\n<ENTER to stop>/Move the cursor to copy"
  )
  (while (not (equal (setq take (grread 't)) '(2 13)))
    (setq code5 (car take))
    (setq p3 (cadr take))
    (if (and p3 (= 5 code5))
      (progn
 (setq ;;find a point perpendicular to p1 & p2
       p4
        (inters p1
         p2
         p3
         (polar p3 (+ (angle p1 p2) (* pi 0.5)) 1.0)
         nil
        )
 )
 (setq ;;use p3 & p4 as a angle of copy, we need a parallel copy
       p1 (polar p1 (angle p4 p3) sep)
       p2 (polar p2 (angle p4 p3) sep)
 )
 (setq lst (readfile))
 (if (and p1 p2)
   (progn
     (if (and (not (member (point2str p1) lst))
       (not (member (point2str p2) lst))
  )
       (entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
     )
     (if (not (member (point2str p1) lst))
       (write2file (point2str p1))
     )
     (if (not (member (point2str p2) lst))
       (write2file (point2str p2))
     )
   )
 )
      )
      (progn
 (prompt
   "\r<ENTER to stop>/Move the cursor to copy"
 )
 (alert
   "\nWorks only at the active view, other commands are disabled."
 )
      )
    )
  )
)
     )
;;;      (lbx-sysvarend)
 (princ)
)
;;; write strings points data to a working temporary file
(defun write2file (n / file p search)
 (setq search (acad-target))
 (setq file (open (strcat search "$par$") "a"))
 (write-line n file)
 (close file)
)
;;; read the working temporary file
(defun readfile (/ file n tmp search)
 (setq search (acad-target))
 (if (findfile (strcat search "$par$"))
   (progn
     (setq file (open (findfile (strcat search "$par$")) "r"))
     (while (setq n (read-line file))
(if (/= n "")
  (setq tmp (append tmp (list n)))
)
     )
     (close file)
   )
 )
 tmp
)
;;; delete working temporary file
(defun file2nil (/ search)
 (setq search (acad-target))
 (if (findfile (strcat search "$par$"))
   (vl-file-delete (findfile (strcat search "$par$")))
   nil
 )
)
;;; use AutoCAD location as a target directory
(defun acad-target ()
 (substr (findfile "ACAD.EXE")
  1
  (- (strlen (findfile "ACAD.EXE")) 
 )
)
;;; conversion of point list to string arguments
(defun point2str (n / x y z)
 (setq x (rtos (car n) 2 6)
y (rtos (cadr n) 2 6)
z (rtos (caddr n) 2 6)
 )
 (strcat x y z)
)
(defun rtd (a) (* (/ a pi) 180.0))
;;; alignment angle (vector direction)
(defun aangle (/ p1 ang)
 (setq p1 (getpoint "\n<Select LINE>/Line from: "))
 (if p1
   (progn
     (setq
ang (getangle
      (strcat "\nAlignment angle <"
       (rtos (rtd atemp) 2 0)
       ">: "
      )
      p1
    )
     )
     (if (= ang nil)
(setq ang atemp)
     )
     (setq atemp ang)
     (setvar "orthomode" 1)
     (list ang p1)
   )
   nil
 )
)
;;; do a vector, returns: list of two
;;; points to construct the vector or nil
(defun vector (/ anglin ang p1 sep)
 (setq sna (getvar "snapang"))
 (setq anglin (aangle))
 (if anglin
   (progn
     (setq ang (car anglin))
     (setq p1 (cadr anglin))
     (setvar "snapang" ang)
     (setq size (getvar "cursorsize"))
     (setvar "cursorsize" 1)
     (initget 6)
     ;;no zero, no negative
     (setq sep
     (getdist p1
       (strcat "\nNext point/Length <"
        (rtos ll)
        ">: "
       )
     )
     )
     (if (= sep nil)
(setq sep ll)
     )
     (if (not ll)
(setq ll 1.0)
     )
     (setq ll sep)
     (if sna
(setvar "snapang" sna)
     )
     (if size
(setvar "cursorsize" size)
     )
     (list p1 (polar p1 ang sep))
   )
   nil
 )
)
(princ)