Bonjour à tous,
J'ai trouvé sur le forum US cette routine, j'ai adapté les commandes avec "_" pour l'internationnalisation, mais
celà ne semble pas suffir !
Comme mon lisp est encore un peut balbutiant , je fais appel
à vous.
Daniel OLIVES
; ------------------------------------------------------------------------------------------
; 05-5 - Ajoute des sommets à une polyligne sans perdre les XDATA
; ------------------------------------------------------------
;;;ADV.LSP ADD VERTEX TO POLYLINE (C)2002, Aniyam Kandiyil
;;;ADDS VERTEX TO A POLYLINE WITHOUT LOOSING XDATA
;;;(command "convertpoly")
(defun c:ADV ()
(setvar "CMDECHO" 0)
(setq PK_PLN (entsel
"\n* Sélectionner le point de la polyligne sélectionnée Hylight où vous souhaitez l'ajouter *")
)
(cond ((= (cdr (assoc 0 (entget (car PK_PLN)))) "LWPOLYLINE") (ADV-IT2))
;|((/= (cdr (assoc 0 (entget (car PK_PLN)))) "LWPOLYLINE")
; (progn
; (setq Result (ARCH:WARNING
; "Voulez vous convertir la sélection\n"
; "Polyligne épaisse par Polyline fine\n"
; "Polyligne?\n\n"
; "SVP sélectionner l'option si aprés...\n"
;)
;)
;)
;)
;|;
((/= (cdr (assoc 0 (entget (car PK_PLN)))) "LWPOLYLINE")
(progn (command "_convertpoly" "l" PK_PLN "") (ADV-IT2))
)
)
;;(cond
;;((= 0 Result) (progn (command "convertpoly" "l" PK_PLN "")(ADV-IT2)))
;;((= 1 Result) (ARCH:CANCEL))
;;)
(princ)
)
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(defun ADV-IT1 ()
(setvar "CMDECHO" 0)
(while (or (not (setq PK_PLN
(entsel
"\n* Pick Lightweight Polyline at point to add Vertex and Stretch: *")
)
)
(/= (cdr (assoc 0 (entget (car PK_PLN)))) "LWPOLYLINE")
)
(ARCH:ALERT-Q
"MsgBox \"You did not select a Lightweight Polyline.\nPlease try again.\"")
)
(ADV-IT2)
(princ))
(defun ADV-IT2 (/ CR_LYR PL_LST XD_LST PL_OPN PL_LYR PK_PNT NR_PNT NE_PNT
EN_PNT AN_MID
EN_PNT EN_PNT1 EN_PNT2 VTX_LST)
(setq CR_LYR (getvar "CLAYER")
PL_LST (entget (car PK_PLN))
PL_WID (cdr (assoc 40 PL_LST))
XD_LST (assoc -3 (entget (car PK_PLN) (list "*")))
PL_OPN (cdr (assoc 70 PL_LST))
PL_LYR (cdr (assoc 8 PL_LST))
PC_PNT (cadr PK_PLN)
PK_PNT (osnap PC_PNT "mid")
NR_PNT (osnap PC_PNT "nea")
NE_PNT (list (car PK_PNT) (cadr PK_PNT))
EN_PNT (osnap PC_PNT "end")
AN_MID (angle PK_PNT EN_PNT)
EN_PNT (polar PK_PNT (+ AN_MID pi) (distance PK_PNT EN_PNT))
EN_PNT2 (list (car EN_PNT) (cadr EN_PNT))
VTX_LST ()
) ;_ end of setq
(foreach
N PL_LST
(if (= (car N) 10)
(setq VTX_LST (append VTX_LST (list (cdr N))))
) ;_ end of if
) ;_ end of foreach
(RVS_VTX)
(entdel (car PK_PLN))
(setvar "CLAYER" PL_LYR)
(setvar "PLINEWID" PL_WID)
(command "_.PLINE" (foreach PT NVTX_LST (command PT)))
(if (= PL_OPN 1)
(command "_.pedit" (entlast) "_c" "")
) ;_ end of if
(if XD_LST
(progn (setq OBJ_LST (entget (entlast)))
(setq OBJ_LST (append OBJ_LST (list XD_LST)))
(entmod OBJ_LST)
) ;_ end of progn
) ;_ end of if
(setvar "CLAYER" CR_LYR)
(command "_stretch" "_c" NR_PNT NR_PNT "" NR_PNT)
(princ)
) ;_ end of defun
(defun RVS_VTX ()
(setq NVTX_LST ())
(setq FOUND NIL)
(setq N 0)
(setq NTH_VTX1 (nth N VTX_LST))
(setq NTH_VTX2 (nth (+ N 1) VTX_LST))
(while (and NTH_VTX1 NTH_VTX2)
(progn (if (not (member NTH_VTX1 NVTX_LST))
(setq NVTX_LST (append NVTX_LST (list NTH_VTX1)))) ;_ end of if
(FMIDP NTH_VTX1 NTH_VTX2)
(if (and (not (member NR_PNT NVTX_LST))
(= (car MIDPNT) (car NE_PNT))
(= (cadr MIDPNT) (cadr NE_PNT))
) ;_ end of and
(setq NVTX_LST (append NVTX_LST (list NR_PNT)))
) ;_ end of if
(if (not (equal NTH_VTX1 NTH_VTX2))
(setq NVTX_LST (append NVTX_LST (list NTH_VTX2)))
) ;_ end of if
(setq N (+ N 1))
(setq NTH_VTX1 (nth N VTX_LST))
(if (not (setq NTH_VTX2 (nth (+ N 1) VTX_LST)))
(progn (if (not (member NR_PNT NVTX_LST))
(setq NVTX_LST (append NVTX_LST (list NR_PNT)))
) ;end of if
(setq NTH_VTX1 NIL)
) ;_ end of progn
) ;_ end of if
) ;progn
) ;while
) ;_ end of defun
(defun FMIDP (SP LP)
(setq MIDPNT (list (/ (+ (car SP) (car LP)) 2.0) (/ (+ (cadr SP) (cadr LP)) 2.0)) ;_ end of list
) ;_ end of setq
) ;_ end of defun
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Remove Pline vertice
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun drop (lst item)
(append (reverse (cdr (member item (reverse lst))))
(cdr (member item lst)))
)
;;;
(defun massoc (key alist / x nlist)
(foreach
x alist
(if (eq key (car x))
(setq nlist (cons (cdr x) nlist))))
(reverse nlist))
;;;
(defun rv (e pt)
(if (= (cdr (assoc 0 (setq e (entget e)))) "LWPOLYLINE")
(progn (setvar "cmdecho" 0)
(command "_undo" "_begin")
(entmod
(drop e
(cons 10
(if (= (type pt) 'LIST)
(progn (setq pt (trans pt 1 (cdr (assoc -1 e))))
(list (car pt) (cadr pt))
)
(nth pt (massoc 10 e))
)
)
)
)
(command "_undo" "_end")
(setvar "cmdecho" 1)
(princ)
)
) ; end if
)
;;;example--->(rv (car (entsel)) 2)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Remove Pline vertice
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:RMV (/ *CURR_OSNAP olderror SelectedEntity PolyProperties iCount iCount2 NewPoly)
(setq *CURR_OSNAP (getvar "osmode"))
(setq olderror *error*)
(setq *error* RVLispError)
(setvar "cmdecho" 0)
(command "_undo" "_begin")
(setvar "osmode" 0)
(setq SelectedEntity (car (entsel "\n* Select Pline to Remove Vertex *")))
(if (and (/= SelectedEntity nil)
(= (cdr (assoc 0 (entget SelectedEntity))) "LWPOLYLINE")
)
(progn (setq PolyProperties (entget SelectedEntity))
(initget 1)
(setvar "osmode" 32)
(setq SelectedVertex (getpoint "\n* Pick Vertex Point to Remove *"))
(setq iCount 0)
(while (< iCount (cdr (assoc 90 PolyProperties)))
(setq VertexPosition (cdr (nth (+ (* iCount 4) 14)
PolyProperties)))
(if (and (= (car VertexPosition) (car SelectedVertex))
(= (cadr VertexPosition) (cadr SelectedVertex)))
(progn (setq iCount2 0)
(while (< iCount2 4)
(setq NewPoly
(vL-remove
(nth (+ (* iCount 4) 14) PolyProperties)
PolyProperties))
(setq iCount2 (1+ iCount2))
)
(setq NewPoly
(subst (cons 90 (1- (cdr (assoc 90
PolyProperties))))
(assoc 90 PolyProperties)
NewPoly))
(entmod NewPoly)
(entupd (cdr (assoc -1 NewPoly)))
(setq iCount (cdr (assoc 90 PolyProperties)))
)
)
(setq iCount (1+ iCount))
)
)
(prompt "\n* No polylines selected! *")
) ; end if
(princ)
) ; end defun
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;
(defun c:AVX (/)
(setq cmde (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq osm (getvar "osmode"))
(setvar "osmode" 32)
(setq pnt (osnap (getpoint "\n* Pick intersection point *") "_int"))
(if pnt
(progn (setq ss (ssget "_C" pnt pnt (list (cons 0
"LWPOLYLINE,POLYLINE"))))
(while (> (sslength ss) 0)
(setq en (ssname ss 0))
(command "_break" en (trans pnt 1 en) "@")
(command "_pedit" "_m" en "_L" "" "_j" 0.000 "" "")
(ssdel en ss)
)
)
)
(setvar "cmdecho" cmde)
(setvar "osmode" osm)
(princ)
) ; end defun
(princ)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
