[RESOLU] erreur sur lisp "OB2WO" de Gille

[dilack]

Bonjour

 

Le lisp se lance correctement mais au moment du choix de supprimer ou non l'objet source j'ai une erreur et le prog ne pas à son terme.

 

"; erreur: ARXLOAD a échoué"

 

J'ai bien les chemins de recherche de fichiers support configurés.

 

Je pense que ça viens de ma version de map, car ce lisp fonctionnait parfaitement sur d'autre version de mémoire.

 

Je suis sur MAP 3D 2016

 

;;; OB2WO 10/03/07
;;; Crée des "Wipeout" à partir des objets sélectionnés (cercle, ellipse, ou polyligne avec arcs)
;;; Fonctionne en 3D
;;; Modifié le 03/11/07
;;; - plusieurs objets peuvent être sélectionnés
;;; - le wipeout est créé sur le calque de l'objet

(defun c:ob2wo (/ ent lst nor lay)
 (vl-load-com)
 (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (if (ssget '((0 . "CIRCLE,ELLIPSE,LWPOLYLINE")))
   (progn
     (initget "Oui Non")
     (setq del (getkword "\nEffacer les objets source ? [Oui/Non] <Non>: "))
     (vla-StartundoMark acdoc)
     (vlax-for	obj (vla-get-activeSelectionSet acdoc)
(setq lst (ent2ptlst obj)
      nor (vlax-get obj 'Normal)
      lay (vla-get-Layer obj)
)
(makeWipeout lst nor lay)
(and (= del "Oui") (vla-delete obj))
     )
     (vla-EndundoMark acdoc)
   )
 )
)

;;; ENT2PTLST
;;; Retourne la liste des sommets successifs du polygone approchant un objet courbe
;;; Coordonnées exprimées dans le SCO

(defun ent2ptlst (ent / obj dist n lst p_lst prec)
 (vl-load-com)
 (if (= (type ent) 'ENAME)
   (setq obj (vlax-ename->vla-object ent))
   (setq obj ent
  ent (vlax-vla-object->ename ent)
   )
 )
 (cond
   ((member (cdr (assoc 0 (entget ent))) '("CIRCLE" "ELLIPSE"))
    (setq dist	(/ (vlax-curve-getDistAtParam
	     obj
	     (vlax-curve-getEndParam obj)
	   )
	   50
	)
   n	0
    )
    (repeat 50
      (setq
 lst
  (cons
    (trans
      (vlax-curve-getPointAtDist obj (* dist (setq n (1+ n))))
      0
      (vlax-get obj 'Normal)
    )
    lst
  )
      )
    )
   )
   (T
    (setq p_lst (vl-remove-if-not
	   '(lambda (x)
	      (or (= (car x) 10)
		  (= (car x) 42)
	      )
	    )
	   (entget ent)
	 )
    )
    (while p_lst
      (setq
 lst
  (cons
    (append (cdr (assoc 10 p_lst))
	    (list (cdr (assoc 38 (entget ent))))
    )
    lst
  )
      )
      (if (/= 0 (cdadr p_lst))
 (progn
   (setq prec (1+ (fix (* 25 (sqrt (abs (cdadr p_lst))))))
	 dist (/ (- (if	(cdaddr p_lst)
		      (vlax-curve-getDistAtPoint
			obj
			(trans (cdaddr p_lst) ent 0)
		      )
		      (vlax-curve-getDistAtParam
			obj
			(vlax-curve-getEndParam obj)
		      )
		    )
		    (vlax-curve-getDistAtPoint
		      obj
		      (trans (cdar p_lst) ent 0)
		    )
		 )
		 prec
	      )
	 n    0
   )
   (repeat (1- prec)
     (setq
       lst (cons
	     (trans
	       (vlax-curve-getPointAtDist
		 obj
		 (+ (vlax-curve-getDistAtPoint
		      obj
		      (trans (cdar p_lst) ent 0)
		    )
		    (* dist (setq n (1+ n)))
		 )
	       )
	       0
	       ent
	     )
	     lst
	   )
     )
   )
 )
      )
      (setq p_lst (cddr p_lst))
    )
   )
 )
 lst
)
;;;
;;;
;;; MakeWipeout
;;; Crée un objet "wipeout" à partir d'une liste de points et du vecteur normal de l'objet

(defun MakeWipeout (pt_lst nor lay / dxf10 max_dist cen dxf_14)
 (or (member "acwipeout.arx" (arx)) (arxload "acwipeout.arx"))
 (setq	dxf10 (list (apply 'min (mapcar 'car pt_lst))
	    (apply 'min (mapcar 'cadr pt_lst))
	    (caddar pt_lst)
      )
 )
 (setq
   max_dist
    (float
      (apply 'max
      (mapcar '- (apply 'mapcar (cons 'max pt_lst)) dxf10)
      )
    )
 )
 (setq cen (mapcar '+ dxf10 (list (/ max_dist 2) (/ max_dist 2) 0.0)))
 (setq
   dxf14 (mapcar
    '(lambda (p)
       (mapcar '/
	       (mapcar '- p cen)
	       (list max_dist (- max_dist) 1.0)
       )
     )
    pt_lst
  )
 )
 (setq dxf14 (reverse (cons (car dxf14) (reverse dxf14))))
 (entmake (append (list '(0 . "WIPEOUT")
		 '(100 . "AcDbEntity")
		 (cons 8 lay)
		 '(100 . "AcDbWipeout")
		 '(90 . 0)
		 (cons 10 (trans dxf10 nor 0))
		 (cons 11 (trans (list max_dist 0.0 0.0) nor 0))
		 (cons 12 (trans (list 0.0 max_dist 0.0) nor 0))
		 '(13 1.0 1.0 0.0)
		 '(70 . 7)
		 '(280 . 1)
		 '(71 . 2)
		 (cons 91 (length dxf14))
	   )
	   (mapcar '(lambda (p) (cons 14 p)) dxf14)
   )
 )
)
;;;
;;;
;;;
(defun errlsp (ch)
(cond
((eq ch "Function cancelled") nil)
((eq ch "quit / exit abort") nil)
((eq ch "console break") nil)
(T (princ ch))
)
(setvar "cmdecho" v1)
(setvar "orthomode" v2)
(setvar "osmode" v3)
(setvar "blipmode" v4)
(setvar "snapang" v5)
(setq *error* olderr)
(princ)
)
(defun C:pte ( / v1 v2 v3 v4 v5 d_pc flag p_o p_f dlt_x d olderr)
(setq v1 (getvar "cmdecho")
v2 (getvar "orthomode")
v3 (getvar "osmode")
v4 (getvar "blipmode")
v5 (getvar "snapang")
)
(setvar "cmdecho" 0)
(setvar "orthomode" 0)
(setvar "blipmode" 0)
(setq olderr *error* *error* errlsp)
(initget 1)
(setq d_pc (getreal "\nEntrer la valeur de la pente (rampe) en % ?: "))
(initget 8)
(setq echll (getpoint "\nEchelle du profil en long X,Y <1000,100>: "))
(if (eq echll ()) (setq echll '(1000 100)))
(setq d_pc (* d_pc (/ (car echll) (cadr echll))))
(setq p_o (getpoint "\nPoint de départ : "))
(if (eq p_o ()) (setq p_o (getvar "lastpoint")))
(initget "Dans Avec _In With")
(if (eq (getkword "\nPente [Dans/Avec] le plan XY : ") "With")
(setq flag T)
(progn
(setvar "snapang" (atan (/ d_pc 100.0)))
(setvar "orthomode" 1)
(setq flag nil)
)
)
(initget 41)
(setq p_f (getpoint p_o "\nPoint final : "))
(setvar "osmode" (+ 16384 (rem (getvar "osmode") 16384)))
(if flag
(progn
(setq dlt_x (sqrt (+ (* (- (car p_o) (car p_f)) (- (car p_o) (car p_f))) (* (- (cadr p_o) (cadr p_f)) (- (cadr p_o) (cadr p_f))))))
(setq d (* dlt_x (/ (sin (atan (/ d_pc 100.0))) (cos (atan (/ d_pc 100.0))))))
(setq p_f (list (car p_f) (cadr p_f) (+ (caddr p_o) d)))
(command "_.line" p_o p_f "")

)
(progn
(setq dlt_x (- (car p_f) (car p_o)))
(setq d (/ dlt_x (cos (atan (/ d_pc 100.0)))))
(command "_.line" p_o (polar p_o (atan (/ d_pc 100.0)) d) "")
)
)
(setvar "cmdecho" v1)
(setvar "orthomode" v2)
(setvar "osmode" v3)
(setvar "blipmode" v4)
(setvar "snapang" v5)
(setq *error* olderr)
(prin1)
)
;;;
;;;
;;;
;;; FUSION - 01/01/06
;;; Crée une polyligne sur le contour de chaque gorupe de polylignes fermées et contiguës sélectionnées.

(defun c:fus	(/ gile_vl_err	     join-pline	       arcbulge
	   AcDoc    Space    ss	      lst      reg
	   Norm	    expl     objs     regs     olst
	   blst	    plst     dlst     tlst     blg
	   pline
	  )
 (vl-load-com)

;;;***************************************************************;;;

 (defun gile_vl_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))
   )
   (setq *error* m:err
  m:err	nil
   )
   (princ)
 )

;;;***************************************************************;;;

 (defun arcbulge (arc)
   (/ (sin (/ (vla-get-TotalAngle arc) 4))
      (cos (/ (vla-get-TotalAngle arc) 4))
   )
 )

;;;***************************************************************;;;

 (setq	AcDoc	(vla-get-activeDocument (vlax-get-acad-object))
Space	(if (= 1 (getvar "CVPORT"))
	  (vla-get-PaperSpace AcDoc)
	  (vla-get-Modelspace AcDoc)
	)
m:err	*error*
*error*	gile_vl_err
 )
 (prompt "\nSélectionnez les polylignes à fusionner: ")
 (if (setq ss (ssget '((0 . "LWPOLYLINE"))))
   (progn
     (vla-StartUndoMark AcDoc)
     (if (setq	reg
	 (vlax-invoke
	   Space
	   'addRegion
	   (mapcar 'vlax-ename->vla-object
		   (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
	   )
	 )
  )
(progn
  (while (cadr reg)
    (vla-boolean
      (car reg)
      acUnion
      (cadr reg)
    )
    (setq reg (cons (car reg) (cddr reg)))
  )
  (setq	reg  (car reg)
	Norm (vlax-get reg 'Normal)
	expl (vlax-invoke reg 'Explode)
  )
  (vla-delete reg)
  (while expl
  (setq	objs (vl-remove-if-not
	       '(lambda	(x)
		  (or
		    (= (vla-get-ObjectName x) "AcDbLine")
		    (= (vla-get-ObjectName x) "AcDbArc")
		  )
		)
	       expl
	     )
	regs (vl-remove-if-not
	       '(lambda (x) (= (vla-get-ObjectName x) "AcDbRegion"))
	       expl
	     )
  )
  (if objs
    (progn
      (setq olst (mapcar '(lambda (x)
			    (list x
				  (vlax-get x 'StartPoint)
				  (vlax-get x 'EndPoint)
			    )
			  )
			 objs
		 )
      )
      (while olst
	(setq blst nil)
	(if (= (vla-get-ObjectName (caar olst)) "AcDbArc")
	  (setq blst (list (cons 0 (arcbulge (caar olst)))))
	)
	(setq plst (cdar olst)
	      dlst (list (caar olst))
	      olst (cdr olst)
	)
	(while
	  (setq
	    tlst (vl-member-if
		   '(lambda (x)
		      (or (equal (last plst) (cadr x) 1e-9)
			  (equal (last plst) (caddr x) 1e-9)
		      )
		    )
		   olst
		 )
	  )
	   (if (equal (last plst) (caddar tlst) 1e-9)
	     (setq blg -1)
	     (setq blg 1)
	   )
	   (if (= (vla-get-ObjectName (caar tlst)) "AcDbArc")
	     (setq
	       blst (cons (cons	(1- (length plst))
				(* blg (arcbulge (caar tlst)))
			  )
			  blst
		    )
	     )
	   )
	   (setq plst (append plst
			      (if (minusp blg)
				(list (cadar tlst))
				(list (caddar tlst))
			      )
		      )
		 dlst (cons (caar tlst) dlst)
		 olst (vl-remove (car tlst) olst)
	   )
	)
	(setq pline
	       (vlax-invoke
		 Space
		 'addLightWeightPolyline
		 (apply	'append
			(mapcar	'(lambda (x)
				   (setq x (trans x 0 Norm))
				   (list (car x) (cadr x))
				 )
				(reverse (cdr (reverse plst)))
			)
		 )
	       )
	)
	(vla-put-Closed pline :vlax-true)
	(mapcar
	  '(lambda (x) (vla-setBulge pline (car x) (cdr x)))
	  blst
	)
	(vla-put-Elevation
	  pline
	  (caddr (trans (car plst) 0 Norm))
	)
	(vla-put-Normal pline (vlax-3d-point Norm))
               (vla-Highlight pline :vlax-true)
	(mapcar 'vla-delete dlst)
      )
    )
  )
  (if regs
    (progn
      (setq
	expl (append (vlax-invoke (car regs) 'Explode)
		     (cdr regs)
	     )
      )
      (vla-delete (car regs))
    )
    (setq expl nil)
  )
)
)
     )
     (vla-EndUndoMark AcDoc)
   )
 )
 (setq	*error*	m:err
m:err nil
 )
 (princ)
)

 

Merci d'avance pour votre retour!

[lecrabe]

Hello

 

Tu regardes cette ligne :

(or (member "acwipeout.arx" (arx)) (arxload "acwipeout.arx"))

 

La routine tente le chargement de "acwipeout.arx" et donc a priori, tu n'as pas cet ARX !!

 

NOTE : A priori "acwipeout.arx" n'est plus inclus dans les AutoCAD / ACAD MAP / ACAD xxxx depuis la 2014 environ ...

 

Dans l'attente du Grand Maitre Gilles !!

 

Bye, lecrabe

[(gile)]

Salut,

 

Tu utilises une vieille version de Obj2wipeout.lsp.

Depuis AutoCAD 2013, acwipeout.arx a été intégré dans acismui.arx

Tu trouveras la dernière version de Obj2wipeout.lsp su cette page.

[dilack]

Merci à tous les deux pour vos réponses, je teste mais je n'ai aucuns doute sur la résolution du problème!

 

 

C'est bien ce que je pensais! Résolu

Modifié le 17 mars 2018 par dilack

[dilack]

Bonjour à tous,

 

je relance le sujet car j'ai changé de version d'autocad map je suis passée sur la version 2019, et ce coup le message d'erreur et "nill" a la validation du message "effacer les objets source?"

 

J'utilise la version "Modifiée le 03/08/2012" du site de Gilles

 

Merci d'avance du retour

[Steven]

Salut à tous,

 

Idem que dilack:

 

Effacer les objets source ? [Oui/Non] <Non>:
nil

 

J'ai aussi la dernière version.

 

C'est dû à quoi?

[(gile)]

Salut,

 

Le fait que 'nil' s'affiche sur la ligne commande est dû au fait que j'ai oublié un (princ) en fin de routine pour une 'sortie silencieuse', mais cela ne devrait en aucun cas altérer le fonctionnement.

J'ai corrigé le code sur gileCAD.

[dilack]

Merci Gilles

[Steven]

Merci, (gile),

 

Je vais donc remplacer l'ancien par le nouveau