Un lisp qui permettrait de créer les contours correpondant à l\'intersection de plusieur contours

[Invité Sylvainhinard]

Bonjour,

 

La semaine je recherchais un lisp qui permettrait de créer les contours correpondant à l'intersection de plusieur contours / polyligne (fermée ou non). Voir le site suivant

http://www.delicad.com/autocad/flashpolygons.php . Après quelques recherches j'ai trouvé un code en LISP qui fonctionne sous Autocad 2007 en Anglais mais qui ne fonctionne pas sur Autocad Map 2011 en français. Je ne connais pas les equivalents anglais / français. Je sollicite donc votre aide.Merci à tous

 

S. HINARD

 

Voici le fameux 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")

 

 

[bonuscad]

Bonjour,

 

Voici une traduction en commandes internationalisées, fonctionnera quelque soit la langue.

 

PS: Edites ton message, tu as une balise certainement mal fermée.

;;; ========================================================================
;;; 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" "_begin")
 (startTimer)
 (setting)
 (setq clayer (getvar "clayer"))
 (command "_.layer" "_new" "bound" "_set" "bound" "_color" 3 "" "")
 (setq a (getpoint "\nCoin haut gauche: "))
 (setq b (getcorner a "\nCoin bas droit: "))
 (setq dis (getdist "\nDistance minimum: "))
 (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" "_set" "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" "_set" clayer "")
   (setq th (+ th th0))
 )
 (resetting)
 (endTimer (vl-symbol-name 'c:bb))
 (command "_.undo" "_end")
)

;
(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" "_Advanced" "_Island" "_No" "") ; advanced options
              ; without island detection
       (if ss
         (command "_Bound" "_New" 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 "\nPurge...")
 (command "_.PURGE" "_Layers" "*" "_No")
 (gc)
 (princ (strcat "\nTemps d'exécution " def ": " (rtos secs 2 6)))
 (princ)
)

(princ "\nUtilisez la commande BB pour l'exécution.")

[Invité Sylvainhinard]

Youpi! Merci beaucoup Bonuscad!

[Invité samuelM]

Bonjour,

 

Cette commande m'intéresse donc j'ai regardé sur internet ce que c'était vraiment. mais le problème c'est que je n'arrive pas à m'en servir.

Je l'ai chargé sur autocad mais après je ne sais pas quoi répondre quand il demande la dimension maximum.

 

Pouvez vous m'aider?

Merci

[Invité samuelM]

Pourquoi avoir réalisé _undo il me met "command: nil"?

[Invité samuelM]

Pourquoi avoir réalisé _undo il me met "command: nil"?

[Invité samuelM]

Pourquoi avoir réalisé _undo il me met "command: nil"?