Création de plusieurs contours sans pointage et sans identifiant

[Invité Sylvainhinard]

Bonjour,

 

Je suis à la recherche d'un lisp qui permettrait de créer les contours correpondant à l'intersection de plusieur contours / polyligne (fermée ou non). Pour resumer je voudrait créer des contours (similaire à ce que l'on fait avec la commande du Menu Dessin -> Contours), mais ceci sans pointer dans la polyligne et sans identifiant au préalable dans les contours à créer. J'espére avoir été clair.

 

Je vous remercie et bonne journée à tous

 

S. HINARD

[didier]

Coucou

 

sans pointer dans la polyligne et sans identifiant

oui, bien sûr!

en lançant le lisp quand même, non ?

 

blague à part, je crois avoir à peu près compris mais sans rien cliquer

ça me semble illusoire

 

peux-tu mettre un fichier exemple à notre disposition

avec avant/après.

 

Gréviste

[Invité Sylvainhinard]

Didier,

 

Après quelques recherche sur Internet j'ai trouvé cette outil qui correspond à mes attentes :

http://www.delicad.com/autocad/flashpolygons.php

 

Existe t-il un tel LISP sous Cadxp ?

 

Bonne journée

 

S. HINARD

[Fraid]

Bonjour,

 

a tu essayé FUSION ?

 

http://www.cadxp.com/XForum+print-fid-58-tid-13085.html

[Invité Sylvainhinard]

Bonjour,

 

J'ai essayé FUSION (très bon programe au passage...) mais cela ne correspond a ce que je recherche (voir message précedent).

Après quelques recherches sur internet j'ai trouvé un bout de code, qui hélas ne fonctionne pas... Pourquoi ? Je vous laisse me répondre.

 

Ci dessous le code :

 

 ;;; ========================================================================
;;; Some of the following code are writen by QJCHEN                         
;;; Civil engineering Department, South China University of Technology      
;;; Purpose: To Find each closed boundary in the selection                  
;;; Version: 0.1                                                            
;;; Limitation: Can't generate the boundary by spline                       
;;; 2006.06.01                                                              
;;; Thanks to the code from Korea friend from http://xoutside.com/          
;;; whose code find the intersections of two points and many object         
;;; And thanks to the initial code from Mr.Tony Hotchkiss at Cadalyst       
;;; Original post :www.Theswamp.org                                         
;;; ========================================================================

(defun c:bb (/ clayer a b dis ay by th th0 lp rp inter1 inter1mid inter2
                inter2mid i len plboundary 
             )
 (command "_undo" "_be")
 (startTimer)
 (setting)
 (setq clayer (getvar "clayer"))
 (command "_layer" "n" "bound" "s" "bound" "c" 3 "" "")
 (setq a (getpoint "\n the left up point"))
 (setq b (getcorner a "\n the bottom right point"))
 (setq dis (getdist "\n the minimum distance"))
 (setq ay (nth 1 a)
       by (nth 1 b)
 )
 (setq th by)
 (setq th0 dis)
 (while (< th ay)
   (setq lp (list (nth 0 a) th 0))
   (setq rp (list (nth 0 b) th 0))
   (grdraw lp rp 249)
   (setq inter1 (vl-Get-Int-Pt lp rp "bound" 0))
   (setq inter1mid (midlist inter1))
   (setq inter2 (vl-Get-Int-Pt lp rp "bound" 1)
         inter2mid (midlista inter2)
   )
   (command "_layer" "s" "bound" "")
   (setq i 0
         len (length inter1)
   )
   (repeat (1- len)
     (setq midpoint (nth i inter1mid))	
     (if (not (member1 midpoint inter2mid))
       (progn
         (setq plboundary (STD-BPOLY midpoint nil))
         (if plboundary
           (setq inter2 (vl-Get-Int-Pt lp rp "bound" 1)
                 inter2mid (midlista inter2)
           )
         )
         )
     )
     (setq i (1+ i))
   )
   (command "_layer" "s" clayer "")
   (setq th (+ th th0))
 )
 (resetting)
 (endTimer (vl-symbol-name 'c:bb))
 (command "_undo" "_e")
)

;
(defun member1 (a b / res)
 (if b
   (foreach x b
     (if (< (distance x a) 0.01)
       (progn
         (setq res T)
       )			       ; (setq res nil)
     )
   )				       ; (setq res nil)
 )
 res
)
(defun midlist (lst / len lst1 midpoint i)
 (setq i 0
       len (length lst)
 )
 (repeat (1- len)
   (setq midpoint (midp (nth i lst) (nth (1+ i) lst)))
   (setq lst1 (append
                lst1
                (list midpoint)
              )
   )
   (setq i (1+ i))
 )
 lst1
)
(defun midlista (lst / len lst1 midpoint i)
 (setq i 0
       len (length lst)
 )
 (repeat (/ len 2)
   (setq midpoint (midp (nth i lst) (nth (1+ i) lst)))
   (setq lst1 (append
                lst1
                (list midpoint)
              )
   )
   (setq i (+ i 2))
 )
 lst1
)

;;; -----------------------------------------------------------------
;;; | The following code taken xarch.tu-graz.ac.at/autocad/stdlib/  |
;;; | Thanks to the great code "STDLIB" that wrote by MR.Reini Urban|
;;; -----------------------------------------------------------------

(defun STD-BPOLY (pt ss / ele)
 (cond
   ((member (type C:BPOLY) '(SUBR EXRXSUBR EXSUBR))
     (if ss
       (C:BPOLY pt ss)		       ; old arx or ads function
       (C:BPOLY pt)
     )
   )
   (pt				       ; >=r14: native command
       (setvar "CMDDIA" 0)
       (setq ele (entlast))	       ; (std-break-command)
       (command "_BPOLY" "_A" "_I" "_N" "") ; advanced options
			       ; without island detection
       (if ss
         (command "_B" "_N" ss "")
       )			       ; define boundary set if ss
       (command "" pt "") (setvar "CMDDIA" 1)
       (if (/= (entlast) ele)
         (entlast)
       )
   )				       ; return created BPOLY
   (T
     (alert "command _BPOLY not available")
   )
 )
)


;;; -------------------------------------------------------------------
;;; | The following code are taken from xoutside.com                  |
;;; | http://xoutside.com/CAD/lisp/lisp_chair.htm                     |
;;; | Thanks to the Korea friend                                      |
;;; | Purpose: Get the intersection of Two object                     |
;;; -------------------------------------------------------------------

(defun vl-Get-Int-Pt (FirstPoint SecondPoint lay layindex / acadDocument
                                mSpace SSetName SSets SSet reapp ex obj
                                Baseline
                    )
 (vl-load-com)
 (setq acadDocument (vla-get-ActiveDocument (vlax-get-acad-object)))
 (setq mSpace (vla-get-ModelSpace acadDocument))
 (setq SSetName "MySSet")
 (setq SSets (vla-get-SelectionSets acadDocument))
 (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-add (list SSets
                                                              SSetName
                                                        )
                           )
     )
   (vla-clear (vla-Item SSets SSetName))
 )
 (setq SSet (vla-Item SSets SSetName))
 (setq Baseline (vla-Addline mspace (vlax-3d-point FirstPoint)
                             (vlax-3d-point SecondPoint)
                )
 )
 (vla-SelectByPolygon SSet acSelectionSetFence
                      (kht:list->safearray (append
                                             FirstPoint
                                             SecondPoint
                                           ) 'vlax-vbdouble
                      )
 )
 (vlax-for obj sset (if (setq ex (kht-intersect
                                                (vlax-vla-object->ename BaseLine)
                                                (vlax-vla-object->ename obj)
                                                lay layindex
                                 )
                        )
                      (setq reapp (append
                                    reapp
                                    ex
                                  )
                      )
                    )
 )
 (vla-delete BaseLine)
 (setq reapp (vl-sort reapp '(lambda (e1 e2)
                               (< (car e1) (car e2))
                             )
             )
 )
 reapp
)


;;; Original post:http://xoutside.com/CAD/lisp/lisp_chair.htm 
;;; Modify little by QJCHEN to filter TEXT SPLINE and layer   
(defun kht-intersect (en1 en2 lay layindex / a b x ex ex-app c d e la2)
 (vl-load-com)
 (setq c (cdr (assoc 0 (entget en1)))
       d (cdr (assoc 0 (entget en2)))
       la2 (cdr (assoc 8 (entget en2)))
 )
 (if (or
       (= c "TEXT")
       (= d "TEXT")
       (= c "SPLINE")
       (= d "SPLINE")
     )
   (setq e -1)
 )
 (if (= layindex 0)
   (if (= la2 lay)
     (setq e -1)
   )
 )
 (if (= layindex 1)
   (if (/= la2 lay)
     (setq e -1)
   )
 )
 (setq En1 (vlax-ename->vla-object En1))
 (setq En2 (vlax-ename->vla-object En2))
 (setq a (vla-intersectwith en1 en2 acExtendNone))
 (setq a (vlax-variant-value a))
 (setq b (vlax-safearray-get-u-bound a 1))
 (if (= e -1)
   (setq b e)
 )
 (if (/= b -1)
   (progn
     (exapp a)
   )
   nil
 )
)

(defun exapp (a)
 (setq a (vlax-safearray->list a))
 (repeat (/ (length a) 3)
   (setq ex-app (append
                  ex-app
                  (list (list (car a) (cadr a) (caddr a)))
                )
   )
   (setq a (cdr (cdr (cdr a))))
 )
 ex-app
)

(defun kht:list->safearray (lst datatype)
 (vlax-safearray-fill (vlax-make-safearray (eval datatype) (cons 0
                                                                 (1-
                                                                     (length lst)
                                                                 )
                                                           )
                      ) lst
 )
)

;;; ----------------------------------------------------------
;;; |           midpoint function                            |
;;; ----------------------------------------------------------
(defun midp (p1 p2)
 (mapcar
   '(lambda (x)
      (/ x 2.)
    )
   (mapcar
     '+
     p1
     p2
   )
 )
)


;;; -----------------------------------------------------------------
;;; | The following code taken from Mr.Tony Hotchkiss at Cadalyst   |
;;; | To set and reset the system variable                          |
;;; -----------------------------------------------------------------

(defun err (s)
 (if (= s "Function cancelled")
   (princ "\nALIGNIT - cancelled: ")
   (progn
     (princ "\nALIGNIT - Error: ")
     (princ s)
     (terpri)
   )				       ; _ end of progn
 )				       ; _ end of if
 (resetting)
 (princ "SYSTEM VARIABLES have been reset\n")
 (princ)
)
;;; err
;;; setting and resetting the system variables
(defun setv (systvar newval / x)
 (setq x (read (strcat systvar "1")))
 (set x (getvar systvar))
 (setvar systvar newval)
)
;;; setv
(defun setting ()
 (setq oerr *error*)
 (setq *error* err)
 (setv "BLIPMODE" 0)
 (setv "CMDECHO" 0)
 (setv "OSMODE" 0)
)
;;; setting
(defun rsetv (systvar)
 (setq x (read (strcat systvar "1")))
 (setvar systvar (eval x))
)
;;; rsetv
(defun resetting ()
 (rsetv "BLIPMODE")
 (rsetv "CMDECHO")
 (rsetv "OSMODE")
 (setq *error* oerr)
)


;;; -----------------------------------------------------------------
;;; | The following code taken from www.theswamp.org                |
;;; | To calculate the time that the program run                    |
;;; -----------------------------------------------------------------

(defun startTimer ()
 (setq time (getvar "DATE"))
)
(defun endTimer (func)
 (setq time (- (getvar "DATE") time)
       seconds (* 86400.0 (- time (fix time)))
 )
 (gc)
 (outPut seconds func)
)
(defun outPut (secs def)
 (princ "\nPurging...")
 (command "PURGE" "Layers" "*" "N")
 (gc)
 (princ (strcat "\nTimed " def ": " (rtos secs 2 6)))
 (princ)
)

(princ "\n Please use the bb command to run")

 

Merci de votre aide et bonne journée à tous

 

S. HINARD