Coupure sur 3D Poly depuis un XYZ & Cylindre virtuel

[lecrabe]

 

 

Hello Boys

 

SVP j'ai un probleme pas simple a resoudre

 

Pre-requis :

 

- Fonctionnement sur AutoCAD/MAP/CIVIL/etc 2007-2008-2009 en Lisp ou V-Lisp

- On travaille dans le SCG

 

Soit UNE polyligne 3D (C en fait une Canalisation) ...

- On selectionne UNE polyligne 3D

 

Soit N blocs/symboles avec N attributs dont 3 attributs X1 & Y1 & Z1

- On choisit un bloc/symbole (par clic ou par son nom) - C en fait un equipement sur la canalisation

- On selectionne classiquement par fenetre, CP, etc

 

Les blocs/symboles sont inseres avec Z=0 ou avec un Z NON NUL !

 

- Selection d'un seuil ou DELTA = xx.xxx par exemple 1.0 (1 metre)

 

***** Traitement demande *****

 

- Pour chaque bloc/symbole, on cree un cylindre virtuel (vers le haut et vers le bas)

d'un rayon de DELTA

 

- A ce moment on recherche l'intersection virtuelle entre la polyligne 3D

et le cylindre virtuel (provenant du point d'insertion du bloc/symbole)

 

- SI PAS D'INTERSECTION :

On force la couleur sur le bloc symbole en ROUGE par exemple

pour montrer qu'il n'y a pas d'intersection

 

- SI INTERSECTION :

 

On coupe la polyligne 3D SANS DEPLACER un quelconque sommet

de la polyligne 3D aux coordonnees X & Y & Z de l'intersection virtuelle

Par la commande COUPURE au point XYZ

 

On reporte dans les 3 attributs X1 & Y1 & Z1 du bloc/symbole

les 3 valeurs X & Y & Z de la coupure

 

Il est tres important de ne pas toucher a la polyligne 3D sauf de la "tronconner" !

 

La polyligne 3D peut avoir des XDATAs, Object Datas (de MAP), Liens ASE -SQL

donc il serait bien de ne pas les abimer/supprimer ...

En principe la commande COUPURE ne touche a rien !

 

J'espere que mon CDC est clair !

 

Le Decapode vous remercie par avance de vos efforts

 

 

[fabcad]

Bonjour,

 

Cher Lecrabe,

 

Attention la commande coupure AutoCAD sur AutoCAD MAP 3D 2008 perd les données d'objets sur l'un des 2 objets résultant.

 

Grrr...

[(gile)]

Salut,

 

D'accord avec fabcad, la commande COUPURE conserve l'entité d'origine sur le premier segment et créé une nouvelle entité pour le segment suivant.

 

- Faut-il copier les Xdatas de la polyligne 3d sur chaque tronçon ?

(je ne suis pas sûr de savoir copier les données issues de MAP)

 

- A ce moment on recherche l'intersection virtuelle entre la polyligne 3D

et le cylindre virtuel (provenant du point d'insertion du bloc/symbole)

 

Sauf dans les cas où la polyligne 3d seait tangent avec le cylindre virtuel, il y aura 2 points d'intersection.

 

- Faut-t-il choisir arbitrairement un de ces 2 points ?

 

Je pense avoir trouvé un algorithme, mais je n'ai pas trop le temps pour le développer ces jours ci, alors un peu de patience, à moins que quelqu'un d'autre ne s'y amuse...

[lecrabe]

 

 

Hello Gilles

 

*** Point 1 ***

 

Je t'envoie par MP une routine (integrant COPY_OD.lsp de MAP) qui utilise la commande COUPURE d'AutoCAD et qui copie les OD (Object Data) de MAP sur le 2eme objet

 

La commande COUPURE d'AutoCAD ne touche pas aux XDATAs ou Liens ASE-SQL d'une entité donc je ne comprend pas bien ta question sur les XDATAs !?

 

A verifier !? Ou alors tu utilises ta propre commande COUPURE !

Dans ce cas il faut bien sur copier les XDATAs et Liens ASE-SQL ...

 

****** Precisions sur le CDC ******

 

- Les blocs ont un point d'insertion XB,YB,ZB et de multiples attributs

dont les fameux X1,Y1,Z1 que la routine va modifier ou plutot remplir !

 

SVP j'ajoute sur le bloc un autre attribut DIST3D

qu'il faudra aussi eventuellement remplir !

 

Le ZB du point d'insertion du bloc/symbole pourra etre a ZERO

ou parfois a une altitude reelle du bloc/symbole

 

- La Polyligne peut etre 3D ou 2D (Z=0 ou avec une elevation eventuelle Z= +/- xx.xx)

 

Je retire mon parametre de rayon de detection (cylindre virtuelle d'interception) !

Mais tu as peut etre besoin d'un cylindre virtuel d'interception pour ton algo !?

 

Par contre j'ajoute un autre parametre : Distance 3D maximum = xxx.xxx

 

Sous entendu si la distance d'interception est superieure au seuil

alors on ne fait aucun traitement because le bloc/symbole

est "trop loin" de la canalisation ou reseau

 

Le but principal de la routine c'est de trouver la distance minimum entre un bloc/symbole

et la polyligne 2D ou 3D, de couper la polyligne aux coordonnees X,Y,Z

et de reporter ces valeurs X,Y,Z sur les attributs X1,Y1,Z1 du bloc/symbole

 

L'attribut DIST3D sera remplie par la distance 3D entre le X,Y,Z (=X1,Y1,Z1)

et le point d'insertion du bloc/symbole (XB,YB,ZB)

 

RAPPEL : A la sortie, si on modifie/remplit X1,Y1,Z1

c'est avec une coordonnee 3D REELLE sur la canalisation ou reseau !!

 

SI PAS D'INTERSECTION (Probleme ou TROP LOIN, voir le seuil) :

On force la couleur sur le bloc/symbole en ROUGE par exemple

pour montrer qu'il n'y a pas d'intersection possible

 

SI INTERSECTION :

On force la couleur sur le bloc/symbole en BLEU par exemple

 

Suis je assez clair ?

 

Encore merci a tous, Le Decapode

 

[(gile)]

Salut,

 

Si j'ai bien compris...

 

(defun c:CutAtBlk (/	  *error*	osm    mspace blk    ss
	   delta  lst	 pl	poly   ins    pt     pts
	   atts	  tag
	  )

 (vl-load-com)
 (or *acdoc*
     (setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))
 )
 (setq	osm    (getvar "osmode")
mspace (vla-get-ModelSpace *acdoc*)
 )

 (defun *error* (msg)
   (or	(= msg "Fonction annulée")
(princ (strcat "\nErreur: " msg))
   )
   (setvar "osmode" osm)
   (vla-EndUndoMark *acdoc*)
   (princ)
 )

 (if
   (and
     (setq blk (GetBlock nil))
     (princ "\nSélectionnez les blocs à traiter ou :")
     (or
(ssget (list '(0 . "INSERT") (cons 2 blk)))
(ssget "_X" (list '(0 . "INSERT") (cons 2 blk)))
     )
     (vlax-for	b (setq ss (vla-get-ActiveSelectionSet *acdoc*))
(setq lst (cons b lst))
     )
     (setq pl (car (entsel "\nSélectionnez la polyligne: ")))
     (setq poly (vlax-ename->vla-object pl))
     (member (vla-get-ObjectName poly)
      '("AcDbPolyline" "AcDb2dPolyline" "AcDb3dPolyline")
     )
     (setq delta (getdist "\nSpécifiez la distance maximum: "))
     (not (vla-delete ss))
   )
    (progn
      (vla-StartUndoMark *acdoc*)
      (foreach	b lst
 (setq ins (vlax-get b 'InsertionPoint)
       pt  (vlax-curve-getClosestPointTo poly ins)
 )
 (if (	   (progn
     (setq pts (cons pt pts))
     (setq atts (vlax-invoke b 'GetAttributes))
     (foreach a	atts
       (setq tag (vla-get-TagString a))
       (cond
	 ((= "X1" tag)
	  (vla-put-TextString a (rtos (car pt)))
	 )
	 ((= "Y1" tag)
	  (vla-put-TextString a (rtos (cadr pt)))
	 )
	 ((= "Z1" tag)
	  (vla-put-TextString a (rtos (caddr pt)))
	 )
	 ((= "DIST3D" tag)
	  (vla-put-TextString a (rtos dist))
	 )
       )
     )
     (vla-put-Color b acBlue)
     (or (equal pt ins 1e-9)
	 (vla-addLine
	   mspace
	   (vlax-3d-point pt)
	   (vlax-3d-point ins)
	 )
     )
   )
   (vla-put-Color b acRed)
 )
      )
      (setq pts (vl-sort pts
		  (function
		    (lambda (x1 x2)
		      (				 (vlax-curve-getParamAtPoint poly x2)
		      )
		    )
		  )
	 )
      )
      (and (equal (car pts) (vlax-curve-getStartPoint poly) 1e-9)
    (setq pts (cdr pts))
      )
      (and (equal (last pts) (vlax-curve-getStartPoint poly) 1e-9)
    (setq pts (reverse (cdr (reverse pts))))
      )
      (setvar "osmode" 0)
      (foreach	p pts
				;(vl-cmdf "_break" pl p p)
 (CutPolyAtPoint pl p)
 (or
   (and
     ade_odgettables
     ade_odrecordqty
     ade_oddelrecord
     ade_odtabledefn
     ade_odgetfield
     ade_odaddrecord
     (copy_data pl (setq pl (entlast)) nil)
   )
   (setq pl (entlast))
 )
      )
      (setvar "osmode" osm)
      (vla-EndUndoMark *acdoc*)
    )
 )
 (princ)
)

;;; CutPolyAtPoint (gile)
;;; Coupe la polyligne (3d ou 2d) au point spécifié et retourne la liste des deux objets générés
;;; (ename ou vla-object selon le type de l'argument pl)
;;; 
;;; Arguments
;;; pl : la polyligne à couper (ename ou vla-object)
;;; pt : le point de coupure sur la polyligne (coordonnées SCG)

(defun CutPolyAtPoint (pl pt / en pa pe cl lc lp)
 (vl-load-com)
 (or (= (type pl) 'VLA-OBJECT)
     (setq pl (vlax-ename->vla-object pl)
    en T
     )
 )
 (setq	pa (fix (vlax-curve-getParamAtPoint pl pt))
pe (fix (vlax-curve-getEndParam pl))
cl (vla-Copy pl)
lc (vlax-get pl 'Coordinates)
lp (reverse lc)
n  0
 )
 (while (    (setq lc (cdddr lc)
  n  (1+ n)
   )
 )
 (while (    (setq lp (cdddr lp)
  n  (1+ n)
   )
 )
 (vlax-put cl
    'Coordinates
    (cons (car pt) (cons (cadr pt) (cons (caddr pt) lc)))
 )
 (vlax-put pl
    'Coordinates
    (reverse
      (cons (caddr pt) (cons (cadr pt) (cons (car pt) lp)))
    )
 )
 (if en
   (list (vlax-vla-object->ename pl)
  (vlax-vla-object->ename pl)
   )
   (list pl cl)
 )
)

;;; Getblock (gile) 03/11/07
;;; Retourne le nom du bloc entré ou choisi par l'utilisateur 
;;; dans une liste déroulante de la boite de dialogue ou depuis la boite
;;; de dialogue standard d'AutoCAD
;;; Argument : le titre (string) ou nil (défaut : "Choisir un bloc")

(defun getblock	(titre / bloc n lst tmp file what_next dcl_id nom)
 (while (setq bloc (tblnext "BLOCK" (not bloc)))
   (setq lst (cons (cdr (assoc 2 bloc)) lst)
   )
 )
 (setq	lst  (acad_strlsort
       (vl-remove-if
	 (function (lambda (n) (= (substr n 1 1) "*")))
	 lst
       )
     )
tmp  (vl-filename-mktemp "Tmp.dcl")
file (open tmp "w")
 )
 (write-line
   (strcat
     "getblock:dialog{label="
     (cond (titre (vl-prin1-to-string titre))
    ("\"Choisir un bloc\"")
     )
     ";initial_focus=\"bl\";:boxed_column{
     :row{:text{label=\"Sélectionner\";alignment=left;}
     :button{label=\">>\";key=\"sel\";alignment=right;fixed_width=true;}}
     spacer;
     :column{:button{label=\"Parcourir...\";key=\"wbl\";alignment=right;fixed_width=true;}}
     :column{:text{label=\"Nom :\";alignment=left;}}
     :edit_box{key=\"tp\";edit_width=25;}
     :popup_list{key=\"bl\";edit_width=25;}spacer;}
     spacer;
     ok_cancel;}"
   )
   file
 )
 (close file)
 (setq dcl_id (load_dialog tmp))
 (setq what_next 2)
 (while (>= what_next 2)
   (if	(not (new_dialog "getblock" dcl_id))
     (exit)
   )
   (start_list "bl")
   (mapcar 'add_list lst)
   (end_list)
   (if	(setq n	(vl-position
	  (strcase (getvar "INSNAME"))
	  (mapcar 'strcase lst)
	)
)
     (setq nom (nth n lst))
     (setq nom	(car lst)
    n	0
     )
   )
   (set_tile "bl" (itoa n))
   (action_tile "sel" "(done_dialog 5)")
   (action_tile "bl" "(setq nom (nth (atoi $value) lst))")
   (action_tile "wbl" "(done_dialog 3)")
   (action_tile "tp" "(setq nom $value) (done_dialog 4)")
   (action_tile
     "accept"
     "(setq nom (nth (atoi (get_tile \"bl\")) lst)) (done_dialog 1)"
   )
   (setq what_next (start_dialog))
   (cond
     ((= what_next 3)
      (if (setq nom (getfiled "Sélectionner un fichier" "" "dwg" 0))
 (setq what_next 1)
 (setq what_next 2)
      )
     )
     ((= what_next 4)
      (cond
 ((not (read nom))
  (setq what_next 2)
 )
 ((tblsearch "BLOCK" nom)
  (setq what_next 1)
 )
 ((findfile (setq nom (strcat nom ".dwg")))
  (setq what_next 1)
 )
 (T
  (alert (strcat "Le fichier \"" nom "\" est introuvable."))
  (setq	nom nil
	what_next 2
  )
 )
      )
     )
     ((= what_next 5)
      (if (and	(setq ent (car (entsel)))
	(= "INSERT" (cdr (assoc 0 (entget ent))))
   )
 (setq nom	 (cdr (assoc 2 (entget ent)))
       what_next 1
 )
 (setq what_next 2)
      )
     )
     ((= what_next 0)
      (setq nom nil)
     )
   )
 )
 (unload_dialog dcl_id)
 (vl-file-delete tmp)
 nom
)


;;;---------------------------------------------------------------------------;
;;;
;;;    COPY_OD.LSP
;;;
;;;    (C) Copyright 1998 by Autodesk, Inc.
;;;
;;;    Permission to use, copy, modify, and distribute this software
;;;    for any purpose and without fee is hereby granted, provided
;;;    that the above copyright notice appears in all copies and
;;;    that both that copyright notice and the limited warranty and
;;;    restricted rights notice below appear in all supporting
;;;    documentation.
;;;
;;;    AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
;;;    AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
;;;    MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK, INC.
;;;    DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
;;;    UNINTERRUPTED OR ERROR FREE.
;;;
;;;    Use, duplication, or disclosure by the U.S. Government is subject to
;;;    restrictions set forth in FAR 52.227-19 (Commercial Computer
;;;    Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
;;;    (Rights in Technical Data and Computer Software), as applicable.
;;;
;;;    July 1996
;;; 
;;;---------------------------------------------------------------------------;
;;;
;;;    DESCRIPTION
;;;
;;;    Copy object data from one object to a set of other objects. If the
;;;    object data to be copied already exists on the target object the
;;;    options to not copy, copy once and copy all are presented.
;;;
;;;    Careful, it is possible to corrupt existing topological data
;;;    using this routine.
;;;
;;;---------------------------------------------------------------------------;

;;;****************************************************************************
;;; Function: COPY_DATA
;;;
;;; Copy object data from the source object to the target object.
;;;
;;; If the data is already found to exist on a target object, the 
;;; user is prompted what to do. Either to replace it only on the 
;;; target, for all objects in  the selection set, or to skip it.
;;;
;;;
(defun COPY_DATA (source_obj target_obj	overwrite ; overwrite flag
	  /	     ct		ct2	   cttemp
	  fld	     fldnme	fldnamelist
	  fldtyp     fldtypelist	   len
	  numrec     OK		tbl	   tbllist
	  tbldef     tblstr	val	   vallist
	 )

 ;; 
 ;; access all OD tables from source object
 ;;
 (if (setq tbllist (ade_odgettables source_obj))
   (progn
     ;;
     ;; for each table on source object
     ;;
     (foreach tbl tbllist
(prompt (strcat "\nProcessing source table " tbl "."))
;;
;; determine if target object has object
;; data records for current table
;;
(setq OK nil)
(setq numrec (ade_odrecordqty target_obj tbl))
;;
;; If the table is found on object ask what to do
;;
(if (and (> numrec 0) (/= overwrite "All"))
  (progn
    (initget "All Yes No")
    (setq overwrite
	   (getkword
	     "\nOverwrite existing record(s) on target? (All/Yes/No) : "
	   )
    )
    (if	(null overwrite)
      (setq overwrite "All")
    )
  )
)
(if (or	(= overwrite "All")
	(= overwrite "Yes")
	(= numrec 0)
    )
  (setq OK T)
)
;;
;; delete all existing records on target 
;; object if overwrite flag is set
;;
(if (and (> numrec 0)
	 (or (= overwrite "Yes") (= overwrite "All"))
    )
  (progn
    (setq ct 0)
    (while (	      (ade_oddelrecord target_obj tbl ct)
      (setq ct (+ ct 1))
    )
  )
)
(if OK
  (progn
    ;;
    ;; build list of field names
    ;;
    (setq tbldef (ade_odtabledefn tbl))
    (setq tblstr (cdr (nth 2 tbldef)))
    (setq fldnamelist ())
    (setq fldtypelist ())
    (foreach fld tblstr
      (setq fldnme (cdr (nth 0 fld)))
      (setq fldtyp (cdr (nth 2 fld)))
      (setq fldnamelist (append fldnamelist (list fldnme)))
      (setq fldtypelist (append fldtypelist (list fldtyp)))
    )
    ;;
    ;; for each record on source object 
    ;;
    (setq numrec (ade_odrecordqty source_obj tbl))
    (setq ct 0)
    (while (	      ;;
      ;; build list of values
      ;;
      (setq cttemp 0)
      (setq vallist ())
      (foreach fld fldnamelist
	(setq typ (nth cttemp fldtypelist))
	(setq cttemp (+ cttemp 1))
	(setq val (ade_odgetfield source_obj tbl fld ct))
	(if (= typ "Integer")
	  (setq val (fix val))
	)
	(setq vallist (append vallist (list val)))
      )
      ;;
      ;; add a record to target object
      ;;
      (ade_odaddrecord target_obj tbl)
      ;;
      ;; populate target record with values from source record
      ;;
      (setq ct2 0)
      (while (		(setq val (nth ct2 vallist))
	(setq fld (nth ct2 fldnamelist))
	(setq ct2 (+ ct2 1))
	(ade_odsetfield target_obj tbl fld ct val)
      )
      (setq ct (+ ct 1))
    ) ;_ while
  )
) ;_ if
     ) ;_ foreach
   )
 ) ;_ if

 ;;
 ;; Return overwrite status so it can 
 ;; be passed back in for the next object.
 ;; 
 overwrite

) ;_ COPY_DATA 

[Edité le 14/9/2008 par (gile)][Edité le 15/9/2008 par (gile)]

 

[Edité le 20/9/2008 par (gile)]

[(gile)]

J'ai modifié le code ci dessus (réparations de dysfonctionnements).

[lecrabe]

 

Hello Gilles

 

Encore merci pour ton aide - Phase 2 des tests en cours ... :) :D

 

Le Decapode (qui tronconne ses reseaux)

 

[(gile)]

Salut,

 

J'ai à nouveau modifié le code, la commande COUPURE (_BREAK) ne semblant pas être très fiable (en tout cas quand elle est lancée depuis un LISP).

J'ai donc remplacé l'appel à cette commande par un appel à une routine (CutPolyAtPoint).

Cette routine devrait fonctionner avec les versions 2007 et postérieures.

 

[Edité le 20/9/2008 par (gile)]