- 积分
- 64557
- 明经币
- 个
- 注册时间
- 2010-5-9
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
发表于 2011-12-15 09:34:39
|
显示全部楼层
;;;; FAQ-CODE.LSP
;;;; Code from the comp.cad.autocad AutoLISP FAQ
;;;; (c) 1991-1997 Reini Urban
;;;;
;;;; This code may only be redistributed together with the FAQ document.
;;;; The FAQ may be freely redistributed in its entirety without
;;;; modification provided that this copyright notice is not removed. It
;;;; may not be sold for profit or incorporated in commercial documents
;;;; (e.g. published for sale on CD-ROM, floppy disks, books, magazines,
;;;; or other print form) without the prior written permission of the
;;;; copyright holder. Permission is expressly granted for this document
;;;; to be made available for file transfer from installations offering
;;;; unrestricted anonymous file transfer on the Internet and to be
;;;; included into the official AutoCAD FAQ.
;;;;
;;;; These functions are, if not otherwise stated, (c) 1991-97
;;;; by Reini Urban and may be freely used. If you include some of those
;;;; functions in your code, you have to add a short line if you intend
;;;; to ship source code or a seperate document to your program where to
;;;; find the FAQ and this code.
;;;;
;;;; This code is provided AS IS without any expressed or implied warranty.
;;;;
;;;; If you intentionally got this copy without the FAQ, get the FAQ at
;;;; http://xarch.tu-graz.ac.at/autocad/...q/autolisp.html
;;;;-----------------------------------------------------------------------
;;;;
;;;; These are some basic AutoLISP functions to make life, faq-writing
;;;; and posting news-answers easier. For more see /autocad/stdlib/
;;;;
;;;; Last update: 6.Dec 99
;;;;
;;;; Version 2.2 13.Jul 99 renamed ssapply to ssmap
;;;; Version 2.0 11.May 98 fixed: arc2bul, ddecmd, tan
;;;; Version 1.10 22.July 97 LWPOLYLINE support and fixes
;;;; Version 1.9 26.June 97 pline-segs, ddecmd, getval
;;;; Version 1.8 15.May 97 R14 fixes, ssapply
;;;; Version 1.71 7.May 97 added (dxf)
;;;;
;;;;-----------------------------------------------------------------------
;;;; [3.3] You may include break functions and debug print into your source
;;;; code.中断函数和打印你的代码
;;; Debugging functions调试函数
(defun break (s)
(if *BREAK*
(progn
(princ "BREAK>> (stop with )\nBREAK>> ")
(princ s)
(while (/= (setq s (getstring "\nBREAK>> ")) "")
(print (eval (read s)))
)
)
)
) ;bugfix from v1.3!
(defun dbg-print (s) ;accepts atoms and lists接受原子和列表
(if *DEBUG*
(if (listp s)
(mapcar 'print s)
(print s)
)
)
)
(defun C:DEBUG () (setq *DEBUG* (not *DEBUG*))) ;switch it on and off
(defun C:BREAK () (setq *BREAK* (not *BREAK*)))
(defun CONT () (setq *BREAK* nil)) ;cont. without any interruption
;;;;[15] How can I pass a variable number of arguments to a lisp function?
;;; MY-PRINC - print a variable number of arguments (of any type)
;;;打印表中各元素;如果不是表,则打印它本身
(defun my-princ (x)
;; simple version, for better stuff look at the SDK2: PRINTF.LLB
(if (listp x)
(mapcar 'princ x)
(princ x)
)
)
;;;; [16] How can I avoid stack overflows?
;;; INTLST - create '(0 1 2 ... n)
;;;产生从0到n的表
(defun intlst (n / l)
(repeat n
(setq l (cons (setq n (1- n)) l))
)
) ;this looks ugly but it works
;;;; [20] general Helper functions
;;; DXF - return the DXF group code of an (entget) list
;;;示例(setq ele (entget (car (entsel))))拾取直线时(dxf 0 ele)返回"LINE"
(defun dxf (grp ele) (cdr (assoc grp ele)))
;;;; [20.1] List manipulation
;;; CONSP - a not empty list测试x是否空表，返回T or nil
(defun consp (x) (and x (listp x)))
;;; POSITION - returns the index of the first element in the list,
;;;返回第一个元素在表中的索引号
;;; base 0, or nil if not found
;;;示例(position x '(a b c)) -> nil, (position b '(a b c d)) -> 1
(defun position (x lst / ret)
(if (not (zerop (setq ret (length (member x lst)))))
(- (length lst) ret)
)
)
;;; REMOVE - Removes an item from a list (double elements allowed)
;;;从表中去除任何元素
;;;示例(remove 0 '(0 1 (0 1) 3 0)) -> (1 (0 1) 3)
;;;有了这个函数,vl-remove还拿来干什么?
(defun remove (ele lst) ; by Serge Volkov
(apply 'append (subst nil (list ele) (mapcar 'list lst)))
)
;;; REMOVE-IF - Conditional remove from flat list,
;;; pred requires exactly 1 arg
;;; (remove-if 'zerop '(0 1 2 3 0)) -> (1 2 3)
;;; (remove-if 'numberp '(0 (0 1) "")) -> ((0 1) "")
;;;可能vl-remove-if就是这样写出来的吧,不然的话,为什么结果一样呢?
(defun remove-if (pred from)
(cond
((atom from) from) ;nil or symbol (return that)
((apply pred (list (car from))) (remove-if pred (cdr from)))
(t (cons (car from) (remove-if pred (cdr from))))
)
)
;;; REMOVE-IF-NOT - keeps all elements to which the predicate applies
;;; say: "keep if", it need not be defined recursively, also like this
(defun remove-if-not (pred lst) ; by Vladimir Nesterowsky
(apply 'append
(mapcar '(lambda (e)
(if (apply pred (list e))
(list e)
)
)
lst
)
)
)
;;; ADJOIN - conses ele to list if not already in list
;;; trick: accepts quoted lists too, such as
;;;元素不在列表中，则加入之
;;;(setq l '(1 2 3))
;;;(adjoin 0 'l)->(0 1 2 3);(adjoin 0 l)->(0 1 2 3)
(defun adjoin (ele lst / tmp)
(if (= (type lst) 'SYM)
(setq tmp lst
lst (eval tmp)
)
)
(setq lst (cond ((member ele lst) lst)
(t (cons ele lst))
)
)
(if tmp
(set tmp lst)
lst
)
)
;;; ROT1 - put the first element to the end, simple version
;;;第一个元素放到最后
;;; Say "rotate by one" or "rotate left"
(defun rot1 (lst) (append (cdr lst) (list (car lst))))
;;; BUTLAST - the list without the last element
;;;去除表中最后一个元素的表
(defun butlast (lst)
(reverse (cdr (reverse lst)))
)
;;;; [20.2] string predicates
;;; STRINGP - string predicate: "is s a string?"
;;;判断是否是字符串->T or nil
(defun stringp (s)
(= (type s) 'STR)
)
;;; STRING-NOT-EMPTYP - is str a not empty string?
;;;是否空字符串->T or nil
(defun string-not-emptyp (s)
(and (stringp s) (/= s ""))
)
;;; for more list and string manipulation code see
;;; AI_UTILS.LSP or
;;; ftp://xarch.tu-graz.ac.at/pub/autocad/lisp/lisp.lsp and string.lsp
;;; or at http://xarch.tu-graz.ac.at/autocad/...estr/strtok.lsp
;;;; [20.3] symbol->string
;;; SYMBOL-NAME - returns the name of a symbol as string
;;; converts any valid lisp expression to its printed representation
;;;1示例(symbol-name 'a) -> "a";(symbol-name a) -> nil
;;;2示例(symbol-name '(0 1 2 a)) -> "(0 1 2 A)"
;;;我想是read的逆操作,直到遇到vl-prin1-to-string我才算解决,原来早就有了?
(defun symbol-name (sym / f str tmp)
;;执行完毕,搜索电脑,没有发现*sym.tmp
;;下句产生临时文件的方法是不是与vl-filename-mktemp相同呢?
(setq tmp "$sym.tmp");temp. filename, should be deleted
(setq f (open tmp "w"))
(princ sym f)
(close f)
(setq f (open tmp "r")
str (read-line f)
f (close f)
)
str
)
;;;; [20.4] AutoCAD entity access
;;; GETVAL - returns the group value of an entity.
;;; like the wellknown (dxf) function but accepts all kinds of
;;; entity representations (ename, entget list, entsel list)
;;;返回组码,与上面那个dxf相同,不过ele可以是图元,图元表,ensel返回值.
(defun GETVAL (grp ele) ;"dxf value" of any ent...
(cond ((= (type ele) 'ENAME) ;ENAME
(cdr (assoc grp (entget ele)))
)
((not ele) nil) ;empty value
((not (listp ele)) nil) ;invalid ele
((= (type (car ele)) 'ENAME) ;entsel-list
(cdr (assoc grp (entget (car ele))))
)
(T (cdr (assoc grp ele)))
)
) ;entget-list
;;;使用示例如下(gettyp (entsel)) => "LINE"之类
(defun GETTYP (ele) ;return type
(getval 0 ele)
)
;;; ENTITY - assure ENAME确保返回值是图元
;;;ele可以是图元,图元表,ensel返回值
;;; convert the entity to type ENAME (to write shorter code)
(defun ENTITY (ele) ;convert to element name
(cond ;accepts the following types:
((= (type ele) 'ENAME) ele) ; ENAME
((not (listp ele)) nil) ; error: no list
((= (type (car ele)) 'ENAME) (car ele)) ; entsel-list
((cdr (assoc -1 ele))) ; entget-list or nil
)
)
;;;and now just:
;;;见上面 dxf GETVAL,一样的使用法
(defun getval (grp ele)
(cdr (assoc grp (entget (entity ele))))
)
;;;示例(istypep ele "TEXT"),is ele a "TEXT"?
;;;ele可以是图元,图元表,ensel返回值
(defun istypep (ele typ) ;check type
(= (gettyp ele) typ)
)
;;;示例(istypep ele '("TEXT" "ATTDEF")),is element a "TEXT" or a "ATTDEF"?
(defun ISTYPEP (ele typ) ;better implementation to accept lists too
(cond
((listp typ) (member (gettyp ele) typ))
((stringp typ) (= (gettyp ele) typ));assume typ uppercase, wcmatch is slower but neater
(T nil)
)
)
;;;示例(getpt (entsel)) => ( 0.1 10.0 24)
;;;组码10是对象定位点
(defun GETPT (ele) ;return the startpoint of any element
(getval 10 ele)
) ;group 10
;;;示例(getflag (entsel))
;;;样条曲线SPLINE线闭合返回11;否则8
;;;多段线LWPOLYLINE线闭合返回1;否则0
(defun GETFLAG (ele) (getval 70 ele)) ;same with the entity flag
;;; FLAGSETP - bitvalue val in flag of element set?
;;; Ex: (flagsetp 1 pline) => T if closed
;;; Ex: (flagsetp 16 vertex) => T if spline control point
(defun FLAGSETP (val ele)
(bitsetp val (getflag ele))
)
;;; Ex: (bitsetp 4 12) => T ;bitvalue 4 (=2.Bit) in 12 (=4+8) is set
(defun BITSETP (val flag)
(= (logand val flag) val)
)
;;; SSLIST - 选择集=>列表
;;; Note: it's also wise to use ai_ssget, because some ents could be
;;; on locked layers使用ai_ssget是明智的,因为有些实体在锁定层上
;;; Ex: (sslist (ai_ssget (ssget))) => list of selected unlocked ents
;;; or (mapcar 'entupd (sslist (ssget "X" '((8 . "TEMP")))))
;;; - regens all entities on layer TEMP
(defun SSLIST (ss / n lst)
(if (= 'PICKSET (type ss))
(repeat (setq n (sslength ss))
(setq n (1- n)
lst (cons (ssname ss n) lst)
)
)
)
)
;;; SSMAP - apply a function to each ent in ss, in reversed order
;;; Faster, but not so easy to understand. see [22.2] Datestamp
;;; [renamed from SSAPPLY to SSMAP to match the stdlib name]
;;; Ex: (ssmap 'entupd (ssget)) ; regenerate only some entities
(defun SSMAP (fun ss / n)
(if (= 'PICKSET (type ss))
(repeat (setq n (sslength ss))
(apply fun (list (ssname ss (setq n (1- n)))))
)
)
)
;;; backwards compatibility alias:
(setq ssapply ssmap)
;;; [21.2] Plot dialog from within Lisp. Using DDE
;;; R13 code! For R12 use "autocad.dde" as the server name. Then, inside your lisp
;;; or script, you can do (ddecmd "_plot "). Function DDECMD will return
;;; nil if something wrong, or the string you passed if successful. The
;;; string is just like what you type under the command prompt from
;;; keyboard, so you need put a space or a return, which is "^13" here,
;;; to end the string.
;;; Besides, the function is very useful in the following situation: If
;;; within a lisp, you need call an AutoCAD transparent command like
;;; LAYER, normally you will use (command "_layer"), but after use this
;;; line, the lisp own will not be transparent. Using the function, you
;;; will solve this problem.
;;; [fixed for all releases]
(defun DDECMD (str / tmp acadver ddestr)
(if (not (boundp 'initiate))
(cond
((= 14 (setq acadver (atoi (getvar "ACADVER"))))
(setq ddestr "AutoCAD.R14.DDE")
(arxload "ddelisp")
)
((= 13 acadver)
(setq ddestr "autocad.r13.dde")
(xload "ddelisp")
)
((= 12 acadver)
(setq ddestr "autocad.dde")
(xload "ddelisp")
)
(T (princ "DDE not supported") (exit))
)
)
(if (not (zerop (setq tmp (initiate ddestr "system"))))
(progn
(execute tmp (strcat "[" str "]"))
(terminate tmp)
str
)
)
)
;;; Visual Lisp Example:
;|
(setq vlax:ActiveDocument (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(setq plt (vla-get-plot vlax:ActiveDocument)) ;=> plot object
(vla-PlotWindow plt pt1 pt2) ; define window (pts in WCS)
(vla-PlotPreview plt 1) ; 0 for partial, 1 for full
(vla-PlotToDevice plt "Default System Printer") ; if it exists
|;
;;;; [21.3] (entmod) and (entmake) Layers, without (command "_LAYER"...)
;;; This sample routine will create a layer with any name you type:
;;; by Reinaldo Togores
(defun C:MLAY ()
(setq laynam (getstring "\nLayer name: "))
(entmake
(list
'(0 . "LAYER")
'(5 . "28")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
(cons 2 laynam)
'(70 . 64)
'(62 . 7)
'(6 . "CONTINUOUS")
)
)
)
;;;; [21.6] (vports), VIEWPORT entity, pixel conversion
;;; Conversion pixel to drawing units
(defun pix2units (pix)
(* pix (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))))
)
;;; Conversion drawing units to pixel
(defun units2pix (units)
(* units
(/ (cadr (getvar "SCREENSIZE")) (getvar "VIEWSIZE"))
)
)
;;;;[21.7] Select all visible objects: zoom coordinates
;;; returns a list of the actual viewport corners in WCS
(defun zoompts (/ ctr h screen ratio size size_2)
(setq ctr (xy-of (getvar "VIEWCTR")) ;3D -> 2D
h (getvar "VIEWSIZE") ;real
screen (getvar "SCREENSIZE") ;2D: Pixel x,y
ratio (/ (float (car screen)) ;aspect ratio
(cadr screen)
)
size (list (* h ratio) h) ;screensize in coords
size_2 (mapcar '/ size '(2.0 2.0))
)
(list (mapcar '- ctr size_2)
(mapcar '+ ctr size_2)
)
)
(defun xy-of (pt) (list (car pt) (cadr pt))) ;assure 2D coords
;;; returns all visible entities as a selection set
;;; one way to define this function
(defun ssall-visible (/ l)
(ssget "C" (car (setq l (maptrans0-1 (zoompts)))) (cadr l))
)
;;; or another
(defun ssall-visible-1 () ;combine "C" and (p1 p2) to one list
(apply 'ssget (append '("C") (maptrans0-1 (zoompts))))
)
;;; map some pts from WCS to UCS, easier with just one argument
(defun maptrans0-1 (pts)
(mapcar '(lambda (pt) (trans pt 0 1)) pts)
)
;;;; [21.8] How to write XYZ data of selected objects to a file?
;;; CDF - comma delimited string
(defun cdf-point (pt)
(strcat (car pt) ", " (cadr pt) ", " (caddr pt))
)
;;; SDF - space delimited, may easier be read back in to AutoCAD
(defun sdf-point (pt)
(strcat (car pt) " " (cadr pt) " " (caddr pt))
)
;;; convert this SDF format back to a point with
(defun str->point (s)
(eval (read (strcat "(" s ")")))
)
;;; Write a XYZ file of all selected objects (SDF see below)
(defun C:XYZ (/ ss fname f)
(if (and (setq ss (ssget))
(setq fname (getfiled "Write XYZ to file"
(strcat (getvar "DWGNAME") ".XYZ")
"XYZ"
7
)
)
(setq f (open fname "w"))
)
(foreach ele (sslist ss) ; -> [20.4]
(foreach pt (getpts ele) ; -> [23.1]
(write-line (cdf-point pt) f)
)
)
)
(if f
(close f)
)
)
;;; => .xyz
;;; 0.45, 12.3, -34.0
;;; For a ASC file (SDF-format) simply change all XYZ to ASC
;;; and cdf-point to sdf-point above.
(defun C:ASC (/ ss fname f)
(if (and (setq ss (ssget))
(setq fname (getfiled "Write ASC to file"
(strcat (getvar "DWGNAME") ".ASC")
"ASC"
7
)
)
(setq f (open fname "w"))
)
(foreach ele (sslist ss) ; -> [20.4]
(foreach pt (getpts ele) ; -> [23.1]
(write-line (sdf-point pt) f)
)
)
)
(if f
(close f)
)
)
;;;; [22] Block Attributes
;;; ATTELE - returns entget-list of attribute attname (STRING) in element
;;; ele or nil if not found
(defun attele (ele attname / rslt)
(if (and (istypep ele "INSERT")
(= (getval 66 ele) 1)
)
(progn
(setq ele (entnext (entity ele)))
(while (and ele (istypep ele "ATTRIB"))
(if (= (strcase (getval 2 ele)) (strcase attname))
(setq rslt (entget ele)
ele nil
) ;break the loop
(setq ele (entnext ele))
)
)
)
)
rslt
)
;;; ATTCHG - change the attribute value of INSERT ele to new (group 1)
(defun attchg (ele attname new / b)
(if (setq b (attele ele attname))
(entmod (subst (cons 1 new) (getval 1 b) b))
)
)
;;; Change all DATESTAMP attributes in all inserted PLOT* blocks
(defun C:DATESTAMP ()
(ssmap
'(lambda (ele)
(attchg ele "DATESTAMP" (today))
(entupd ele)
)
(ssget "X" '((0 . "INSERT") (2 . "PLOT*")))
)
)
;;; TODAY - return todays date, could be a DIESEL or this string conversion
;;; with DIESEL it's easier to define it according your format (i.e day of week)
(defun today (/ s)
(setq s (rtos (getvar "CDATE") 2)) ;gets the julian date
(strcat (substr s 5 2)
"-"
(substr s 7 2)
"-"
(substr s 3 2)
)
)
;;; MAIN-ENTITY - some more helper funcs to get the main entity of any attribute
;;; or vertex
(defun main-entity (ele)
(setq b (entity b)) ;force ENAME
(while (istypep b '("ATTRIB" "ATTDEF" "VERTEX"))
(setq b (entnext b))
) ;loop until no more sub-ents
(if (istypep b '("SEQEND" "ENDBLK"))
(getval -2 b) ;complex entity -> header
b ;normal entity
)
)
;;;; [23] Polylines
;;; return only some assoc values in the list (for LWPOLYLINE)
(defun GROUP-ONLY (grp lst)
(mapcar 'cdr
(remove-if-not '(lambda (pair) (= grp (car pair))) lst)
)
)
;;; return the vertex list of a polyline or of any other element
;;; Note that with edlgetent mentioned in [22.1] it's a one-liner
(defun GETPTS (ele / pts)
(setq ele (entity ele)) ;force type ENAME
(cond
((istypep ele "POLYLINE")
(while (istypep (setq ele (entnext ele)) "VERTEX")
;; omit fit and spline points (conservative style)
(if (not (or (flagsetp 1 ele) (flagsetp 8 ele))) ;bugfix!
(setq pts (cons (trans (getpt ele) ele 0) pts))
)
(reverse pts)
)
)
;; Special case: you have to map it, assoc finds only the first.
;; Fix a LWPOLYLINE bug in R14: internally stored as 2d point,
;; (entget) returns fantasy z-values.
((istypep ele "LWPOLYLINE")
(mapcar '(lambda (pt) (trans (list (car pt) (cadr pt) 0.0) ele 0))
(group-only 10 (entget ele))
)
)
;; insert here possible other types, such as
((istypep ele '("TEXT" "CIRCLE")) (list (getpt ele)))
;; more like this (serge's style)
(T
(apply 'append
(mapcar
'(lambda (n / p)
(if (setq p (getval n ele))
(list p)
)
)
'(10 11 12 13)
)
)
)
;; or like this (conservative style)
;;(T (foreach n '(10 11 12 13)
;; (if (setq p (getval n ele)) (setq pts (cons p pts))))
;; pts
;;)
)
)
;;; This sample converts all selected elements to polylines and
;;; tries to join as much as possible.
(defun C:JOINPOLY (/ ele ss)
(foreach ele (sslist (setq ss (ssget))) ;better process lists
(if (entget ele) ;not already joined
(cond ;(then it would be nil)
((istypep ele '("ARC" "LINE"))
;; in fact you should check Z of lines and UCS here too
(command "_PEDIT" ele "_Y" "_J" ss "" "") ; convert and JOIN
)
((and (istypep ele '("POLYLINE" "LWPOLYLINE")) ;bugfix
(not (flagsetp 1 ele)) ;not closed
(< (rem (getflag ele) 128) 8)
) ;ignore meshes and such
(command "_PEDIT" ele "_J" ss "" "") ;ucs check omitted
)
)
)
)
)
;;; Sets new polywidth for multiple plines
(defun C:POLYWID (/ wid ele)
(initget 5)
(setq wid (getdist "New Polyline Width: ")) ;not negative
(foreach ele (sslist (ssget '((0 . "*POLYLINE")))) ;only PLINES
(command "_PEDIT" ele "_W" wid "")
)
)
;;; Draws a POLYLINE entity from a list of points (same with SPLINE,
;;; or LINE), on the actual UCS, with actual OSNAP settings
(defun draw-pline (pts)
(command "_PLINE")
(mapcar 'command pts)
(command "")
)
(defun draw-spline (pts)
(command "_SPLINE")
(mapcar 'command pts) ; the pts must be the fitpoints then
(command "" "" "")
)
;;; add up the LENGTH of all selected objects, NOISY, you can do the
;;; same with AREAs: simply change the last line to (getvar "AREA")
(defun C:LEN-OF ()
(command "_AREA" "_A" "_E") ;add up objects (R12+13)
(ssmap 'command (ssget)) ;pass all elements to AutoCAD
(command "" "") ;two returns
(getvar "PERIMETER")
) ;this is the length
;;; calculates length of a pline, quiet
(defun POLY-LENGTH (poly / seg)
(apply '+ ; the sum of all single segment lengths
(mapcar
'(lambda (seg) ;length of one segment
(if (zerop (car seg)) ;is it straight?
(distance (cadr seg) (caddr seg)) ; line segment or
(abs (arclen seg))
)
) ; curved: -> [24]
(pline-segs poly)
)
)
) ;segment list (bulge p1 p2)
;;; returns all group codes of the complex element
;;; (vertices, attributes) as list, similar to (edlgetent)
(defun CPLX-LIST (grp ele / lst)
(if (= 1 (getval 66 ele))
(progn (setq ele (entnext (entity ele)))
(while (and ele (not (istypep ele "SEQEND")))
(setq lst (cons (getval grp ele) lst)
ele (entnext ele)
)
)
(reverse lst)
)
)
)
;;; PLINE-SEGS - Creates a segment list for the polyline pname
;;; as a list of '(bulge p1 p2). A straight line has bulge 0.0
;;; Compute pts in ECS of pname. Accepts LWPOLYLINE's
(defun pline-segs (pname / pts segs)
(setq segs
(mapcar 'list
(if (istypep pname "LWPOLYLINE")
(group-only 42 (entget pname))
(cplx-list 42 pname)
)
(setq pts (getpts pname)) ; ->[23.1]
(rot1 pts)
)
) ; ->[20.1]
(if (flagsetp 1 pname)
segs ;closed
(butlast segs)
)
) ;open: without the last segment, ->[20.1]
;;; Example: (a bit optimized for brevity :)
;;; Add up all the lengths of all selected polylines, quiet
;;; To accept also other entities, add those to pline-segs
(defun C:POLYLEN ()
(apply '+ (ssmap 'poly-length (ssget '((0 . "*POLYLINE")))))
)
;;;; [24] Circle/Arc Geometry: BULGE conversion, some trigonometry
;;; SEG2CIR - converts a bulged segment (bulge pt1 pt2) of a polyline
;;; to a circle (ctr rad), the start- and endpoints are known
;;; therefore the angles too: (angle ctr pt1)(angle ctr pt2)
;;; returns nil on a straight segment!
(defun seg2cir (seg / bulge p1 p2 cot x y rad dummy)
(if (zerop (car seg)) ;straight line => invalid circle
nil
(setq bulge (car seg)
p1 (cadr seg)
p2 (caddr seg)
cot (* 0.5 (- (/ 1.0 bulge) bulge))
x (/ (- (+ (car p1) (car p2)) (* (- (cadr p2) (cadr p1)) cot))
2.0
)
y (/ (+ (+ (cadr p1) (cadr p2)) (* (- (car p2) (car p1)) cot))
2.0
)
rad (distance (list (car p1) (cadr p1)) (list x y))
dummy (list (list x y) rad) ; return this, I hate progn's
)
)
)
;;; ARC2SEG - inverse conversion:
;;; calculates segment (bulge p1 p2) of arc
;;; with given circle (ctr rad), start-angle, end-angle
;;; (arc2seg cir (angle (car cir) p1) (angle (car cir) p2)) =>seg
(defun arc2seg (cir ang1 ang2 / p1 p2)
(setq p1 (polar (car cir) ang1 (cadr cir))
p2 (polar (car cir) ang2 (cadr cir))
)
(list (arc2bul p1 p2 cir) p1 p2)
)
;;; ARC2BUL - calculates bulge of arc given the arc points and the
;;; circle (ctr rad) [fixed by Serge Pashkov]
(defun arc2bul (p1 p2 cir / ang)
(setq ang (- (angle (car cir) p2) (angle (car cir) p1)))
(if (minusp ang)
(setq ang (+ (* 2.0 pi) ang))
)
(tan (/ ang 4.0))
)
;;; BUL2ANG - returns inner angle of arc (bulge)
(defun bul2ang (seg / ctr)
(- (angle (setq ctr (car (seg2cir seg))) (cadr seg))
(angle ctr (caddr seg))
)
)
;;; ARC2ANG
;;; calculates angle of arc given the chord distance and radius
(defun arc2ang (chord rad)
(* 2.0
(atan
(/ chord
2.0
(sqrt (- (expt rad 2)
(expt (/ chord 2.0) 2)
)
)
)
)
)
)
;;; ARCLEN - length of arc = radius*angle,
;;; Note: +-, you'll need (abs (arclen seg))
(defun arclen (seg)
(* (cadr (seg2cir seg)) ; radius
4.0
(atan (car seg))
)
) ; angle = 4*atan(bulge)
(setq *INFINITY* 1.7e308) ; largest double
(defun tan (z / cosz) ; [fixed]
(if (zerop (setq cosz (cos z)))
*INFINITY*
(/ (sin z) cosz)
)
)
(defun dtr (ang) (* pi (/ ang 180.0))) ; degree to radian
(defun rtd (ang) (/ (* ang 180.0) pi)) ; radian to degree
;;;;[26] EED Extended Entity Data: Select, Get and Store
;;; here is how to get the eed list from one element for all regapps
(defun get-eedlist-all (ele)
(cdadr (assoc -3 (entget (entity ele) '("*"))))
)
;;; this gets all elements of appnames rname (wildcards allowed)
(defun ssget-app (rname)
(ssget "X" (list (list -3 (list rname))))
)
;;; Check any XDATA with: (entget (car (entsel)) '("*"))
;;; GETXDATA - get all XDATA lists from an element
;;; i.e with XDATA:
;;; (-3 ("HUBU-1" (1000 ."ASSHATCH")(1002 ."{")
;;; (1070 . 1)(1002 ."}")))
;;; =>(("HUBU-1" (1000 ."ASSHATCH")(1002 ."{")(1070 . 1)(1002 ."}")))
(defun getxdata (e apnlst)
(cdr (assoc -3 (entget e apnlst)))
)
;;; GETXDATA-ALL - all lists without the regapp name
;;; => ((1000 ."ASSHATCH")(1002 ."{")(1070 . 1)(1002 ."}"))
(defun getxdata-all (e apnlst)
(apply 'append (mapcar 'cdr (getxdata e apnlst)))
)
;;; Conversion pixel to drawing units
(defun PIX2UNITS (pix)
(* pix (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))))
)
;;; Conversion drawing units to pixel
(defun UNITS2PIX (units)
(* units
(/ (cadr (getvar "SCREENSIZE")) (getvar "VIEWSIZE"))
)
)
|
|
置顶卡
变色卡
显身卡
楼主