我的一些lisp编码。。。
这里，将是我的一些autolisp/vital lisp/visual lisp/dcl。。。希望这仍然会有一些用处，关于lisp我失去了练习，现在不再用lisp写了。
REDODIM公司
选择一个分解尺寸，它将被重新完成，这是为了学习如何重新创建分解尺寸。
(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)
MTLSTAIR公司
按照UBC代码绘制金属楼梯的楼层平面和剖面。
包含了当时最丑陋的源代码，但很有帮助——在zip文件中，我写了这个例程，当时我在一个高层项目（32层楼的酒店）上工作，负责所有楼梯的分析。
mtlstair。拉链 感谢您与我们分享您的日常活动。
谢谢你，李， 区域读取器-AR
选择闭合多段线，它将在命令行上显示该区域以及一些可用选项。
;; 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)
从分组点列表中绘制多段线
一种从点绘制多段线的简单方法，其中一条线是由两个点SP-EP和一个凸起数据组成的列表，它由三个点SP-MP-EP表示
;; 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
自定义自动保存控件
一种将自动保存文件备份到特定文件夹位置（C：自动保存）的方法，格式前缀为BAK_（dwgname）
注意：在每个打开的文件上加载反应器，并在保存图形后进行保存。
(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)
反应器Wiz
一种控制visual lisp对象反应器的方法。
包含的例程示例生成详图、注释记号和圆形气泡符号。
一些控件或功能包括：
-属性的位置控制。
-指定一个对象来控制复制。复制此对象时，它将创建一个新符号并将其添加到同一反应器。
-当符号中的一个对象被删除时，整个符号也将被删除。
希望这会有意义。。。
部分代码示例-（所有源代码和vlisp.prj都在附带的zip中）
;;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)
;;;_____________________________________________________________
...
(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。拉链 尊敬的先生：
Lisp程序很好
谢谢分享你的Lisp程序 LCOPY公司
行复制器或多行偏移器，这个超旧的例程所做的是绘制或选择一条线，然后在给出偏移距离后，通过移动光标，它将偏移到我们移动光标并垂直于所选线的一侧。
从未完成例行程序（按原样工作），然后（1994年）我试图模拟我在Intergraph Microstation 4.0中使用的命令，当时这是一个很棒的偏移工具，不知道是否仍然可用。
来自Microstation的那一个能够选择线并将光标移动到一边，它将绘制偏移量，并以相反的方式删除偏移量的线。
对于那些Lisp程序的人来说，这可能是一个很好的挑战。
(vl-load-com)
(defun C:LCOPY (/ p1 p2 p3 p4 sep lcopyent
entlist m s n c lst
objtake code5mklin
)
;;; (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)
页:
[1]
2