ET中已知函数的整理
ET中已知函数的整理1 aly1004在破解ET中fas文件，这很好，可供大家学习。
2 前段时间，ll_j提出了类(apply ''((a b) (+ a b)) '(101 102))的写法供大家讨论
其实ET中提供了一些已知的函数，大家可以临摹。只不过，在没有仔细读完之前，我们并不知道这些已知函数怎么使用。换言之，这些
已经函数需要输入什么，最后输出什么，尽管有英文说明,哪有中文亲切呢。下面我整理了两个，有示例，这样理解就容易多了。
有兴趣的，把自己学习整理的已知函数ET贴出来，大家相互学习提高。
前段时间，ll_j提出了类(apply ''((a b) (+ a b)) '(101 102))的写法供大家讨论,今天我在ET的已知函数中看到了类似的写法。
;;(setq lst (list (getpoint)(getpoint)(getpoint)(getpoint)));(wipeout_clipit nil lst)
(defun wipeout_clipit (na lst / A LA N NA2)
(if na
(entdel na)
)
(if (setq la (acet-layer-locked (getvar "clayer")))
(command "_.layer" "_un" (getvar "clayer") "")
)
(command "_.pline")
(setq n 0)
(repeat (length lst)
(setq a (nth n lst)) ;setq
(command a)
(setq n (+ n 1)) ;setq
) ;repeat
(command "")
(setq na2 (entlast))
(command "_.pedit" na2 "_cl" "_x")
(command "_.wipeout" "_n" na2 "_y")
(if la
(command "_.layer" "_lock" (getvar "clayer") "")
)
)
;;take a list of point ans removes duplicated points and unneeded points
;;as a result of no angle change.
;;去除相邻重复点，并形成封闭(plist_optimize '((1 2)(1 2)(3 4)(3 4)));((1 2) (3 4) (1 2))
(defun plist_optimize (lst / A B C D LST2 N)
(if (not (equal (car lst) (last lst) 0.00001))
(setq lst (append lst (list (car lst))))
)
(setq n 0)
(repeat (max 0 (- (length lst) 1))
(setq a (nth n lst)
b (nth (+ n 1) lst)
)
(if (equal n 0)
(setq lst2 (list a b))
)
(setq c (nth (max (- (length lst2) 2) 0) lst2)
d (last lst2)
)
(if (equal (angle a b)
(angle c d)
0.000001
)
(setq lst2 (reverse (cdr (reverse lst2))))
)
(if (not (equal b (last lst2)))
(setq lst2 (append lst2 (list b)))
)
(setq n (+ n 1))
)
(if (and (>= (length lst2) 4)
(equal (angle (car lst2) (cadr lst2))
(angle (nth (- (length lst2) 2) lst2) (last lst2))
0.000001
)
)
(setq lst2 (cdr lst2)
lst2 (reverse (cdr (reverse lst2)))
)
)
lst2
)
;;层是否处理锁定状态
;;(acet-layer-locked (getvar "clayer"))
(defun acet-layer-locked (layer)
(if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" layer)))))
layer
)
)
继续啊 vlisp2012 发表于 2013-9-2 15:18 static/image/common/back.gif
继续啊
你也整点3
;; Pline width change
;;改多段线 线宽(chgplwidths (ssget '((0 . "*POLYLINE"))) 50)
(defun chgplwidths (plines newWidth / count ent subEntity currVertex)
(setq count 0)
(while (< count (sslength plines))
(setq ent (entget (ssname plines count)))
(if (= (cdr (assoc 0 ent)) "LWPOLYLINE")
(command "_.pedit"
(ssname plines count)
"_width"
newWidth
"_exit"
)
(progn ;polylines
(setq subEntity (entnext (ssname plines count)))
(setq currVertex (entget subEntity))
(while (not (equal "SEQEND" (cdr (assoc 0 currVertex))))
(setq currVertex
(subst (cons 40 NewWidth) (assoc 40 currVertex) currVertex)
)
(setq currVertex
(subst (cons 41 NewWidth) (assoc 41 currVertex) currVertex)
)
(entmod currVertex)
(setq subEntity (entnext (cdr (assoc -1 currVertex))))
(setq currVertex (entget subEntity))
) ;while
(entupd (ssname plines count))
) ;progn
) ;if
(setq count (1+ count))
) ;while
)
;; Pline modification to close
;;使多段线闭合(chgplclose (ssget '((0 . "*POLYLINE"))))
(defun chgplclose (plines / count)
(setq count 0)
(while (< count (sslength plines))
(command "_.pedit" (ssname plines count) "_close" "_exit")
(setq count (1+ count))
)
)
;; Pline modification to open
;;闭合多段线开(chgplopen (ssget '((0 . "*POLYLINE"))))
(defun chgplopen (plines / count)
(setq count 0)
(while (< count (sslength plines))
(command "_.pedit" (ssname plines count) "_open" "_exit")
(setq count (1+ count))
)
)
;; Pline vertex linetype generation switch
;;1 = Extra vertex created by curve-fitting
;;2 = Curve-fit tangent defined for this vertex. A curve-fit tangent direction of 0 may be omitted from DXF output but is significant if this bit is set
;;4 = Not used
;;8 = Spline vertex created by spline-fitting
;;16 = Spline frame control point
;;32 = 3D polyline vertex
;;64 = 3D polygon mesh
;;128 = Polyface mesh vertex
;;(chgltgen (ssget '((0 . "*POLYLINE"))))
(defun chgltgen (plines / count new70 opt ent)
(setq count 0)
(initget 0 "ON OFF eXit _ON OFF eXit")
(setq opt (getkword "Full PLINE linetype? <eXit>: "))
(if opt
opt
"eXit"
)
(if (= opt "ON")
(while (< count (sslength plines))
(setq ent (entget (ssname plines count)))
(setq new70 (cons 70 (logior 128 (cdr (assoc 70 ent)))))
(setq ent (subst new70 (assoc 70 ent) ent))
(entmod ent)
(setq count (1+ count))
) ;while
) ;if on
(if (= opt "OFF")
(while (< count (sslength plines))
(setq ent (entget (ssname plines count)))
(setq new70 (cons 70 (boole 6 128 (cdr (assoc 70 ent)))))
(setq ent (subst new70 (assoc 70 ent) ent))
(entmod ent)
(setq count (1+ count))
) ;while
) ;if off
)
(setq plines (ssget))
;; Pline decurve
;;多段线中弧线变直(chgdecurve (ssget '((0 . "*POLYLINE"))))
(defun chgdecurve (plines / count)
(setq count 0)
(while (< count (sslength plines))
(command "_.pedit" (ssname plines count) "_decurve" "_exit")
(setq count (1+ count))
) ;while
)
;; Pline curve fit
;;多段线拟合(chgfit (ssget '((0 . "*POLYLINE"))))
(defun chgfit (plines / count)
(setq count 0)
(while (< count (sslength plines))
(command "_.pedit" (ssname plines count) "_fit" "_exit")
(setq count (1+ count))
) ;while
)
;; Pline spline fit
;;多段线变成spline进行拟合(chgspline (ssget))
(defun chgspline (plines / count)
(setq count 0)
(while (< count (sslength plines))
(command "_.pedit" (ssname plines count) "_spline" "_exit")
(setq count (1+ count))
) ;while
)
;; Convert arcs and lines to polylines
;; ss is retained as a duplicate of the plines selection set because
;; after conversion, new handles are assigned to what were arcs and lines
;;线、弧转换成轻多段线(convert (ssget '((0 . "LINE,ARC"))))
(defun convert (plines / ss count opt)
(if (> (sslength plines) 0)
(progn
(initget 0 "Yes No _Yes No")
(setq opt (getkword
"Convert Lines and Arcs to polylines? <Yes>: "
)
)
) ;progn then
) ;if
(if (not opt)
(setq opt "Yes")
)
(if (and (= opt "Yes")
(> (sslength plines) 0)
) ;and
(progn ;if yes -- convert lines and arcs to polylines
(setq ss (ssadd))
(setq count 0)
(while (< count (sslength plines))
(if (or (equal (assoc 0 (entget (ssname plines count)))
'(0 . "ARC")
)
(equal (assoc 0 (entget (ssname plines count)))
'(0 . "LINE")
)
) ;or
(progn
(command "_.pedit" (ssname plines count) "_yes" "_exit")
(ssadd (entlast) ss)
) ;progn true
(ssadd (ssname plines count) ss)
) ;if
(setq count (1+ count))
) ;while
) ;progn yes
(progn ;if no -- do not convert
(setq ss plines)
(setq count 0)
(while (< count (sslength ss))
(if (or (equal (assoc 0 (entget (ssname ss count))) '(0 . "ARC"))
(equal (assoc 0 (entget (ssname ss count))) '(0 . "LINE"))
) ;or
(progn
(ssdel (ssname ss count) ss)
(setq count (1- count))
) ;progn true
) ;if
(setq count (1+ count))
) ;while
) ;progn no
) ;if
(if (and ss
(equal (type ss) 'PICKSET)
(equal 0 (sslength ss))
) ;and
(setq ss nil)
) ;if
ss
) 本帖最后由 自贡黄明儒 于 2013-9-2 16:24 编辑
从选择集中分离出指定类型的选择集
;;从选择集中分离出指定类型的选择集
;;(acet-pljoin-ss-flt (ssget "X") (list(cons 0 "CIRCLE")))
(defun acet-pljoin-ss-flt (ss flt )
(if (and ss
(> (sslength ss) 0)
)
(progn
(command "_.select" ss "")
(setq ss (ssget "_p" flt))
)
(setq ss nil)
)
ss
) 前排支持,大师真牛! ;;; TEXTFIT.LSP
(defun c:textfit (/ ename textent newend tmp start newpt val ltc_% ss txtsz)
(acet-error-init
(list
(list "cmdecho" 0 "snapang" 0 "limcheck" 0 "orthomode" 1)
T ;flag. True means use undo for error clean up.
)
)
(if (not (and
(setq ss (ssget "_i"))
(= (sslength ss) 1)
(setq ename (ssname ss 0)
)
)
)
(setq ename (car (entsel "\nSelect Text to stretch or shrink:")))
)
(cond
((not (setq textent (if ename
(entget ename)
)
)
)
(princ "\nNo object selected!")
)
((/= (acet-dxf 0 textent) "TEXT")
(princ "\nSelected object is not Text!")
)
((acet-layer-locked (acet-dxf 8 textent))
(princ "\nSelected object is on a locked layer!")
)
(t
(setq txtsz (textbox textent))
;;文字宽度newend
(setq newend (distance
(list
(caadr txtsz) ;upper right x coord
(cadar txtsz) ;lower left y coord
)
(car txtsz)
;; ll xyz
)
)
;;set snap along text entity
(setvar "snapang"
(angtof (angtos (acet-dxf 50 textent) 0 8) 0)
)
(initget 0 "Start _Start")
(setq
tmp (getpoint (acet-dxf 10 textent)
"\nSpecify end point or : "
)
)
(setvar "snapang" 0)
(cond
((= (type tmp) 'STR)
;;new starting point to be selected
(setq start (getpoint "\nSpecify new starting point: "))
(if start
(progn
(command "_.UCS" "_E" (acet-dxf -1 textent))
(setvar "orthomode" 1);正交
(setq newpt
(if start
(getpoint (trans start 0 1) " ending point: ")
nil
) ;if
) ;setq
(if newpt
(setq newpt (trans newpt 1 0))
)
(setvar "orthomode" 0)
(command "_.UCS" "_W");世界坐标系
)
)
if
)
((not (null tmp))
;;new ending point selected
(setq start (acet-dxf 10 textent)
newpt tmp
)
)
(t
(setq start nil
newpt nil
)
)
) ;cond
(if (and start newpt)
(progn
(setq val (assoc 41 textent)
;;current width factor
val (if val
(cdr val)
1.0
)
ltc_% (* (/ (distance start newpt) newend) val)
textent (subst (cons 41 ltc_%)
(assoc 41 textent)
textent
)
textent (subst (cons 10 start)
(assoc 10 textent)
textent
)
textent (subst (cons 11 newpt)
(assoc 11 textent)
textent
)
) ;setq
(entmod textent)
(entupd (acet-dxf -1 textent))
)
)
;;end of points check
)
) ;cond
(acet-error-restore)
(princ)
) ;end defun
(defun c:TFHELP (/)
(prompt
" TEXTFIT will change the width factor of the selected text, \n"
)
(prompt " to fit within the user specified points.\n")
(prompt "\n")
(prompt
" TEXTFIT will prompt:Select Text to stretch/shrink:\n"
)
(prompt " The user is expected to select the text.\n")
(prompt "\n")
(prompt
" TEXTFIT will then prompt:Specify starting Point/<select new ending point>: \n"
)
(prompt
" At which time the user can specify a new ending point \n"
)
(prompt " or\n")
(prompt
" The user can provide the letter \"S\" for a new starting point\n"
)
(prompt
" to which TEXTFIT will prompt:Specify new starting point:\n"
)
(prompt " and:ending point: \n")
(textscr)
(princ)
)
(defun ACET-DXF (CODE E1)
(CDR (ASSOC CODE E1))
)
(defun acet-layer-locked (layer)
(if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" layer)))))
layer
)
)
前排支持,大师真牛! ，整理出来就一系列函数集了，相当于lisp增加了新函数 顶下，这个确实很好，前面想提出它的layer 相关命令，搞半天，搞不定，不知道缺了什么东东 我想，LAYER可能不是用lisp写的
页:
[1]
2