Mã nguồn
Lưu mã sau dưới dạng tệp tin PLDIET.lsp
Code: PLDIET
;;; PLDIET.lsp [command name: PLDIET]
;;; To put lightweight PolyLines on a DIET (remove excess vertices); usually
;;; used for contours with too many too-closely-spaced vertices.
;;; Concept from PVD routine [posted on AutoCAD Customization Discussion
;;; Group by oompa_l, July 2009] by Brian Hailey, added to by CAB, and
;;; WEED and WEED2 routines by Skyler Mills at Cadalyst CAD Tips [older
;;; routines for "heavy" Polylines that won't work on newer lightweight ones];
;;; simplified in entity data list processing, and enhanced in other ways [error
;;; handling, default values, join collinear segments beyond max. distance,
;;; limit to current space/tab, account for change in direction across 0 degrees,
;;; option to keep or eliminate arc segments] by Kent Cooper, August 2009.
;;; Last edited 28 August 2013
;;; Added reporting, CAD Studio, 2018
;
(defun C:PLD
(/ *error* cmde disttemp cidtemp arctemp plinc plsel pl
pldata ucschanged front 10to42 vinc verts vert1 vert2 vert3 n1 n2)
;
(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break,ruš"))
(princ (strcat "\nError: " errmsg))
); end if
(if ucschanged (command "_.ucs" "_prev"))
; ^ i.e. don't go back unless routine reached UCS change but didn't change back
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
); end defun - *error*
;
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(setq
disttemp
(getdist
(strcat
"\nKhoang cach toi da cho phep"
(if *distmax* (strcat " <" (rtos *distmax* 2 2) ">") ""); default only if not first use
": "
); end strcat
); end getdist & disttemp
*distmax*
(cond
(disttemp); user entered number or picked distance
(*distmax*); otherwise, user hit Enter - keep value
); end cond & *distmax*
cidtemp
(getangle
(strcat
"\nGoc toi da cho phep"
(strcat ; offer prior choice if not first use; otherwise 10 degrees
" <"
(if *cidmax* (angtos *cidmax*) (angtos (/ pi 18))) ; was 12
">"
); end strcat
": "
); end strcat
); end getdist & cidtemp
*cidmax*
(cond
(cidtemp); user entered number or picked angle
(*cidmax*); Enter with prior value set - use that
((/ pi 18)); otherwise [Enter on first use] - 10 degrees
); end cond & *cidmax*
plinc 0 ; incrementer through selection set of Polylines
); end setq
(initget "Retain Straighten")
(setq
arctemp
(getkword
(strcat
"\nGiu nguyen duong cong hay duoi thang [R/S] <"
(if *arcstr* (substr *arcstr* 1 1) "R"); at first use, R default; otherwise, prior choice
">: "
); end strcat
); end getkword
*arcstr*
(cond
(arctemp); if User typed something, use it
(*arcstr*); if Enter and there's a prior choice, keep that
("Retain"); otherwise [Enter on first use], Retain
); end cond & *arcstr*
); end setq
;
(prompt "\nChon LWPolylines to put on a diet, or press Enter to select all: ")
(cond
((setq plsel (ssget '((0 . "LWPOLYLINE"))))); user-selected Polylines
((setq plsel (ssget "_X" (list '(0 . "*POLYLINE") (cons 410 (getvar 'ctab))))))
; all Polylines [in current space/tab only]
); end cond
;
(repeat (sslength plsel)
(setq pl (ssname plsel plinc))
(while
(equal (vlax-curve-getStartPoint pl) (vlax-curve-getPointAtParam pl 1) 1e-6)
; to correct for possibility that more than one vertices at beginning coincide,
; in which case Pline does not define a CS under UCS OBject, causing error
(command "_.pedit" pl "_edit" "_straighten" "" "" "_go" "_exit" "")
); while
(setq pldata (entget pl))
(if (/= (cdr (last pldata)) (trans '(0 0 1) 1 0)); extr. direction not parallel current CS
; for correct angle & distance calculations [projected onto current construction
; plane], since 10-code entries for LWPolylines are only 2D points:
(progn
(command "_.ucs" "_new" "_object" pl) ; set UCS to match object
(setq ucschanged T) ; marker for *error* to reset UCS if routine doesn't
); end progn
); end if
(setq
front ; list of "front end" [pre-vertices] entries, minus entity names & handle
(vl-remove-if
'(lambda (x)
(member (car x) '(-1 330 5 10 40 41 42 210))
); end lambda
pldata
); end removal & front
10to42 ; list of all code 10, 40, 41, 42 entries only
(vl-remove-if-not
'(lambda (x)
(member (car x) '(10 40 41 42))
); end lambda
pldata
); end removal & 10to42
vinc (/ (length 10to42) 4); incrementer for vertices within each Polyline
verts nil ; eliminate from previous Polyline [if any]
n1 vinc ; old # of vertices
); end setq
(if (= *arcstr* "Straighten")
(progn
(setq bulges ; find any bulge factors
(vl-remove-if-not
'(lambda (x)
(and
(= (car x) 42)
(/= (cdr x) 0.0)
); end and
); end lambda
10to42
); end removal & bulges
); end setq
(foreach x bulges (setq 10to42 (subst '(42 . 0.0) x 10to42)))
; straighten all arc segments to line segments
); end progn
); end if
(repeat vinc
(setq
verts ; sub-group list: separate list of four entries for each vertex
(cons
(list
(nth (- (* vinc 4) 4) 10to42)
(nth (- (* vinc 4) 3) 10to42)
(nth (- (* vinc 4) 2) 10to42)
(nth (1- (* vinc 4)) 10to42)
); end list
verts
); end cons & verts
vinc (1- vinc) ; will be 0 at end
); end setq
); end repeat
(while (nth (+ vinc 2) verts); still at least 2 more vertices
(if
(or ; only possible if chose to Retain arc segments
(/= (cdr (assoc 42 (nth vinc verts))) 0.0); next segment is arc
(/= (cdr (assoc 42 (nth (1+ vinc) verts))) 0.0); following segment is arc
); end or
(setq vinc (1+ vinc)); then - don't straighten from here; move to next
(progn ; else - analyze from current vertex
(setq
vert1 (cdar (nth vinc verts)) ; point-list location of current vertex
vert2 (cdar (nth (1+ vinc) verts)); of next one
vert3 (cdar (nth (+ vinc 2) verts)); of one after that
ang1 (angle vert1 vert2)
ang2 (angle vert2 vert3)
); end setq
(if
(or
(equal ang1 ang2 0.0001); collinear, ignoring distance
(and
(<= (distance vert1 vert3) *distmax*)
; straightens if direct distance from current vertex to two vertices later is
; less than or equal to maximum; if preferred to compare distance along
; Polyline through intermediate vertex, replace above line with this:
; (<= (+ (distance vert1 vert2) (distance vert2 vert3)) *distmax*)
(<=
(if (> (abs (- ang1 ang2)) pi); if difference > 180 degrees
(+ (min ang1 ang2) (- (* pi 2) (max ang1 ang2)))
; then - compensate for change in direction crossing 0 degrees
(abs (- ang1 ang2)); else - size of difference
); end if
*cidmax*
); end <=
); end and
); end or
(setq verts (vl-remove (nth (1+ vinc) verts) verts))
; then - remove next vertext, stay at current vertex for next comparison
(setq vinc (1+ vinc)); else - leave next vertex, move to it as new base
); end if - distance & change in direction analysis
); end progn - line segments
); end if - arc segment check
); end while - working through vertices
(setq
front (subst (cons 90 (length verts)) (assoc 90 front) front)
; update quantity of vertices for front end
10to42 nil ; clear original set
); end setq
(foreach x verts (setq 10to42 (append 10to42 x)))
; un-group four-list vertex sub-lists back to one list of all 10, 40, 41, 42 entries
(setq pldata (append front 10to42 (list (last pldata))))
; put front end, vertex entries and extrusion direction back together
(entmake pldata)
;(PRINT (length (vl-remove-if-not '(lambda (x) (= (car x) 10)) pldata)))
(setq n2 (length (vl-remove-if-not '(lambda (x) (= (car x) 10)) pldata)))
(entdel pl); remove original
(setq plinc (1+ plinc)); go on to next Polyline
(if ucschanged
(progn
(command "_.ucs" "_prev")
(setq ucschanged nil) ; eliminate UCS reset in *error* since routine did it already
); end progn
); end if - UCS reset
(princ (strcat "\n" (rtos n1 2 0) "-->" (rtos n2 2 0) " (" (rtos (* (/ (- n2 n1) (* 1.0 n1)) 100.0) 2 2) "%)"))
); end repeat - stepping through set of Polylines
(princ (strcat "\n" (itoa plinc) " polyline" (if (> plinc 1) "s" "") " simplified."))
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
(princ)
); end defun - PLD
(defun C:PLDIET ()
(C:PLD)(princ)
)
(prompt "\nType PLD to put PolyLines on a Diet.")(princ)
hoặc AVX.lsp
Code: AVX
;;;
;;; AVX : Add VerteX on Pline (LW, 2D, 3D)
;;; DVX : Del Vertex on Pline (LW, 2D, 3D)
;;;
;;; Special version for US/English people
;;;
;;
;; AVX - from (gile) Gilles Chanteau - (12/05/07)
;; Ajoute un sommet au point spécifié à une extrémité ou sur le segment sélectionné d'une polyligne
;;
(defun c:avx (/ err AcDoc pl ob pk pa ap typ org
ucs ocs pt sp ep co no p1 p2 pt ce
a1 a2 bu
)
(vl-load-com)
(defun err (msg)
(if (or
(= msg "Fonction annulée")
(= msg "quitter / sortir abandon")
)
(princ)
(princ (strcat "\nErreur: " msg))
)
(and ucs (vla-put-activeUCS AcDoc ucs))
(and ocs (vla-delete ocs) (setq ocs nil))
(vla-EndUndoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(setq *error* m:err
m:err nil
)
)
(setq m:err *error*
*error* err
AcDoc (vla-get-activeDocument (vlax-get-acad-object))
)
(while (and
(setq pl (entsel))
(setq ob (vlax-ename->vla-object (car pl)))
(setq typ (vla-get-Objectname ob))
)
(if (or (= typ "AcDbPolyline")
(and (member typ '("AcDb2dPolyline" "AcDb3dPolyline"))
(= 0 (vla-get-Type ob))
)
)
(progn
(vla-StartUndoMark AcDoc)
(setq pk
(if (= typ "AcDb3dPolyline")
(trans (osnap (cadr pl) "_nea") 1 0)
(vlax-curve-getClosestPointToProjection
ob
(trans (cadr pl) 1 0)
(mapcar '-
(trans (getvar "VIEWDIR") 1 0)
(trans '(0 0 0) 1 0)
)
)
)
)
(setq ap (/ (* (getvar "APERTURE")
(getvar "VIEWSIZE")
)
(cadr (getvar "SCREENSIZE"))
)
)
(if (= typ "AcDbPolyline")
(setq co (split-list (vlax-get ob 'Coordinates) 2))
(setq co (split-list (vlax-get ob 'Coordinates) 3))
)
(cond
((equal pk (vlax-curve-getStartPoint ob) ap)
(setq pa 0)
(if (= (vla-get-Closed ob) :vlax-false)
(setq sp (vlax-curve-getStartPoint ob)
ep nil
)
(setq ep nil
sp nil
)
)
)
((equal pk (vlax-curve-getEndPoint ob) ap)
(setq pa (1- (length co)))
(if (= (vla-get-Closed ob) :vlax-false)
(setq ep (vlax-curve-getEndPoint ob)
sp nil
)
(setq ep nil
sp nil
)
)
)
(T
(setq pa (atoi (rtos (vlax-curve-getParamAtPoint ob pk)))
ep nil
sp nil
)
)
)
(if (and (/= typ "AcDb3dPolyline")
(or
(not (equal (trans '(0 0 1) 1 0 T)
(setq no (vlax-get ob 'Normal))
1e-9
)
)
(and (= typ "AcDbPolyline")
(/= 0 (vla-get-Elevation ob))
)
(and (= typ "AcDb2dPolyline") (/= 0 (caddar co)))
)
)
(progn
(setq ucs (vla-add
(vla-get-UserCoordinateSystems AcDoc)
(vlax-3d-point (setq org (getvar "UCSORG")))
(vlax-3d-point (mapcar '+ org (getvar "UCSXDIR")))
(vlax-3d-point (mapcar '+ org (getvar "UCSYDIR")))
"avxUCS"
)
ocs (vla-add
(vla-get-UserCoordinateSystems AcDoc)
(vlax-3d-Point
(setq org (vlax-curve-getStartPoint ob))
)
(vlax-3d-Point
(mapcar '+ org (trans '(1 0 0) no 0))
)
(vlax-3d-Point
(mapcar '+ org (trans '(0 1 0) no 0))
)
"avxOCS"
)
)
(vla-put-activeUCS AcDoc ocs)
)
)
(if (setq
pt
(getpoint (trans (vlax-curve-getPointAtParam ob pa) 0 1)
;;; "\nSpecifiez le sommet à ajouter: "
"\nSpecify the Segment/Arc for Vertex to Add : "
)
)
(progn
(and ep (setq pa (- (length co) 2)))
(if (/= typ "AcDb3dPolyline")
(progn
(setq p1 (trans (vlax-curve-getPointAtParam ob pa) 0 no)
pt (trans pt 1 no)
p2 (trans (vlax-curve-getPointAtParam ob (1+ pa))
0
no
)
)
(cond
((and ep (/= 0 (vla-getBulge ob pa)))
((lambda (a)
(setq
bu
(list (cons (1+ (fix pa)) (/ (sin a) (cos a))))
)
)
(/
(- (angle p2 pt)
(+ (angle p2 p1)
(* 2 (atan (vla-getBulge ob pa)))
pi
)
)
2.0
)
)
)
((and sp (/= 0 (vla-getBulge ob pa)))
((lambda (a)
(setq
bu (list (cons 0 (/ (sin a) (cos a))))
)
)
(/
(- (+ (angle p1 p2)
(* -2 (atan (vla-getBulge ob pa)))
pi
)
(angle p1 pt)
)
2.0
)
)
)
(T
(setq
ce ((lambda (mid1 mid2)
(inters mid1
(polar mid1
(+ (angle p1 pt) (/ pi 2))
1.0
)
mid2
(polar mid2
(+ (angle pt p2) (/ pi 2))
1.0
)
nil
)
)
(mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0))
p1
pt
)
(mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0))
pt
p2
)
)
)
(if (or (= 0 (vla-getBulge ob pa)) (null ce))
(setq a1 0.0
a2 0.0
)
(if (< pi
(ang<2pi (- (angle pt p2) (angle p1 pt)))
(* 2 pi)
)
(setq a1 (- (ang<2pi (- (angle ce p1) (angle ce pt)))
)
a2 (- (ang<2pi (- (angle ce pt) (angle ce p2)))
)
)
(setq a1 (ang<2pi (- (angle ce pt) (angle ce p1)))
a2 (ang<2pi (- (angle ce p2) (angle ce pt)))
)
)
)
(setq bu
(list (cons pa (/ (sin (/ a1 4.0)) (cos (/ a1 4.0))))
(cons (1+ (fix pa))
(/ (sin (/ a2 4.0)) (cos (/ a2 4.0)))
)
)
)
)
)
)
)
(cond
((= typ "AcDbPolyline")
(setq pt (list (car pt) (cadr pt)))
)
((= typ "AcDb3dPolyline") (setq pt (trans pt 1 0)))
)
(or sp (setq pa (1+ pa)))
(cond
(sp (setq co (cons pt co)))
(ep (setq co (append co (list pt))))
(T
(setq co (append (sublst co 1 pa)
(cons pt (sublst co (1+ pa) nil))
)
)
)
)
(or
(= typ "AcDb3dPolyline")
(while (<= (setq pa (1+ pa)) (vlax-curve-getEndParam ob))
(setq bu (cons (cons pa (vla-getBulge ob (1- pa))) bu))
)
)
(vlax-put ob 'Coordinates (apply 'append co))
(or (= typ "AcDb3dPolyline")
(mapcar '(lambda (x) (vla-setBulge ob (car x) (cdr x)))
bu
)
)
(and ucs (vla-put-activeUCS AcDoc ucs))
(vla-EndUndoMark AcDoc)
)
)
)
(progn
;; (alert "Entité non valide.")
(alert "Entity Not Valid.")
(exit)
)
)
)
(and ocs (vla-delete ocs) (setq ocs nil))
(setq *error* m:err
m:err nil
)
(princ)
)
;;
;; DVX - from (gile) Gilles Chanteau - (12/05/07)
;; Supprime le sommet sélectionné d'une polyligne (LW, 2D ou 3D)
;;
(defun c:dvx (/ err os pt ent typ plst par blst n)
(vl-load-com)
(defun err (msg)
(if (or
(= msg "Fonction annulée")
(= msg "quitter / sortir abandon")
)
(princ)
(princ (strcat "\nErreur: " msg))
)
(vla-EndUndoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(setvar "OSMODE" os)
(setq *error* m:err
m:err nil
)
)
(setq m:err *error*
*error* err
os (getvar "OSMODE")
)
(setvar "OSMODE" 1)
(while (setq pt
(getpoint
;; "\nSélectionnez le sommet à supprimer: "
"\nSelect the Vertex to Del/Erase: "
)
)
(if (and
(setq ent (ssget pt
'((-4 . "<OR")
(0 . "LWPOLYLINE")
(-4 . "<AND")
(0 . "POLYLINE")
(-4 . "<NOT")
(-4 . "&")
(70 . 118)
(-4 . "NOT>")
(-4 . "AND>")
(-4 . "OR>")
)
)
)
(setq ent (vlax-ename->vla-object (ssname ent 0)))
(setq typ (vla-get-ObjectName ent))
)
(if
(and
(setq plst (if (= typ "AcDbPolyline")
(split-list (vlax-get ent 'Coordinates) 2)
(split-list (vlax-get ent 'Coordinates) 3)
)
)
(< 2 (length plst))
)
(progn
(vla-StartUndoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(setq pt (trans pt 1 0)
par (cond
((equal pt (vlax-curve-getStartPoint ent) 1e-9)
0
)
((equal pt (vlax-curve-getEndPoint ent) 1e-9)
(1- (length plst))
)
(T
(atoi (rtos (vlax-curve-getParamAtPoint ent pt))
)
)
)
blst nil
n 0
)
(or (= typ "AcDb3dPolyline")
(repeat (length plst)
(if (/= n par)
(setq
blst
(cons (cons (length blst) (vla-getBulge ent n))
blst
)
)
)
(setq n (1+ n))
)
)
(vlax-put ent
'Coordinates
(apply 'append (vl-remove (nth par plst) plst))
)
(or (= typ "AcDb3dPolyline")
(mapcar '(lambda (x) (vla-setBulge ent (car x) (cdr x)))
blst
)
)
(vla-EndUndoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
)
)
(progn
;; (alert "\nLa polyligne n'a que deux sommets. ")
(alert "\nThe Pline has ONLY 2 Vertex. ")
(exit)
)
)
(progn
;; (alert "Entité non valide.")
(alert "Entity not Valid.")
(exit)
)
)
)
(setvar "OSMODE" os)
(setq *error* m:err
m:err nil
)
(princ)
)
;;; SUBLST Retourne une sous-liste
;;; Premier élément : 1
;;; (sublst '(1 2 3 4 5 6) 3 2) -> (3 4)
;;; (sublst '(1 2 3 4 5 6) 3 nil) -> (3 4 5 6)
(defun sublst (lst start leng / rslt)
(if (not (<= 1 leng (- (length lst) start)))
(setq leng (- (length lst) (1- start)))
)
(repeat leng
(setq rslt (cons (nth (1- start) lst) rslt)
start (1+ start)
)
)
(reverse rslt)
)
;; SPLIT-LIST Retourne une liste de sous-listes
;; Arguments
;; - lst : la lste à fractionner
;; - num : un entier, le nombre d'éléments des sous listes
;; Exemples :
;; (split-list '(1 2 3 4 5 6 7 8) 2) -> ((1 2) (3 4) (5 6) (7 8))
;; (split-list '(1 2 3 4 5 6 7 8) 3) -> ((1 2 3) (4 5 6) (7 8))
(defun split-list (lst n)
(if lst
(cons (sublst lst 1 n)
(split-list (sublst lst (1+ n) nil) n)
)
)
)
;;; Ang<2pi Retourne l'angle, à 2*k*pi près, compris entre 0 et 2*pi
(defun ang<2pi (ang)
(if (and (<= 0 ang) (< ang (* 2 pi)))
ang
(ang<2pi (rem (+ ang (* 2 pi)) (* 2 pi)))
)
)
Link tải AutoLISP
--------------------------------------------------------------------------------------
Hướng dẫn in nhiều file dwg
Ứng dụng D2P do AJS phát triển
Mọi thông tin xin liên hệ Fanpage AutoLISP Thật là đơn giản!
Cảm ơn bạn đã theo dõi!
Không có nhận xét nào:
Đăng nhận xét