Xref rélatif-chemin complet

[La Lozère]

Bonjour,

Je récupère un fichier avec plein d'XREF enregistrés avec leurs chemin complet.

Est-il possible de changer les chemins pour les mettre en relatif?

Merci.

[Patrick_35]

Salut

 

;;;=================================================================
;;;
;;; RXREF.LSP V2.00
;;;
;;; Mettre un chemin relatif aux xrefs
;;;
;;; Copyright (C) Patrick_35
;;;
;;;=================================================================

(defun c:rxref(/ bl cmd doc tot)

 (defun relatif(base rech / fich file loc1 pos1 pos2 resu)
   (and (vl-filename-extension rech)
     (setq fich (strcat (vl-filename-base rech) (vl-filename-extension rech))
     rech (vl-filename-directory rech)
     )
   )
   (setq ch (vl-string-translate "\\" "/" base)
  rc (vl-string-translate "\\" "/" rech)
   )
   (or (eq (substr ch (strlen ch) 1) "/") (setq ch (strcat ch "/")))
   (or (eq (substr rc (strlen rc) 1) "/") (setq rc (strcat rc "/")))
   (setq pos1 (vl-string-search "/" ch)
  loc1 1
   )
   (while (and pos1 (= (strcase (substr ch 1 pos1)) (strcase (substr rc 1 pos1))))
     (setq loc1 pos1
    pos1 (vl-string-search "/" ch (1+ pos1))
     )
   )
   (cond
     ((< loc1 4)
(setq resu rc)
     )
     ((eq (strlen ch) (1+ loc1))
(if (eq (strlen rc) (1+ loc1))
  (setq resu "./")
  (setq resu (strcat "./" (substr rc (+ 2 loc1))))
)
     )
     ((/= (strlen rc) (1+ loc1))
(setq pos2 loc1
      resu (substr rc (+ 2 loc1))
)
(while (setq pos2 (vl-string-search "/" ch (1+ pos2)))
  (setq resu (strcat "../" resu))
)
     )
   )
   (and resu
     (progn
(and fich (setq resu (strcat resu fich)))
(or (member (substr rech (strlen rech) 1) '("/" "\\"))
  (setq resu (vl-string-right-trim "/" resu))
)
(and (vl-string-search "\\" rech)
  (setq resu (vl-string-translate "/" "\\" resu))
)
     )
   )
   resu
 )

 (vl-load-com)
 (setq doc (vla-get-activedocument (vlax-get-acad-object))
tot 0
cmd (getvar "cmdecho")
 )
 (vla-startundomark doc)
 (princ "\nTravail en cours...")(princ)
 (setvar "cmdecho" 0)
 (vlax-for bl (vla-get-blocks doc)
   (and (eq (vla-get-isxref bl) :vlax-true)
 (setq resu (findfile (vla-get-path bl)))
        (setq resu (relatif (getvar "dwgprefix") resu))
 (setq tot (1+ tot))
;      (vla-put-path bl resu)
     (vl-cmdf "_.xref" "_path" (vl-filename-base resu) resu)
   )
 )
 (setvar "cmdecho" cmd)
 (vla-endundomark doc)
 (princ (strcat "\nModification de " (itoa tot) " chemin(s)"))
 (princ)
)

(setq nom_lisp "RXREF")
(if (/= app nil)
 (if (= (strcase (substr app (1+ (- (strlen app) (strlen nom_lisp))) (strlen nom_lisp))) nom_lisp)
   (princ (strcat "..." nom_lisp " chargé."))
   (princ (strcat "\n" nom_lisp ".LSP Chargé.....Tapez " nom_lisp " pour l'éxecuter.")))
 (princ (strcat "\n" nom_lisp ".LSP Chargé......Tapez " nom_lisp " pour l'éxecuter.")))
(setq nom_lisp nil)
(princ)

 

@+

[La Lozère]

Merci, super.

Quel réactivité....

Par contre marche pas sur les images, mais c'est pas grave j'en ai que 2.

A plus.

[(gile)]

Salut,

 

Pour les xrefs imbriquées le chemin relatif ne sera pas retenu. Il faut les traiter depuis le fichier parent.

 

Je donne quand même ce que j'avais

(defun c:xrel (/ fltr ss blk path)
 (vl-load-com)
 (or *acad* (setq *acad* (vlax-get-acad-object)))
 (or *acdoc* (setq *acdoc* (vla-get-ActiveDocument *acad*)))
 (or *blocks* (setq *blocks* (vla-get-Blocks *acdoc*)))
 (setq	fold (getvar 'dwgprefix)
fltr ""
 )
 (vlax-for blk	*blocks*
   (if	(= (vla-get-IsXref blk) :vlax-true)
     (setq fltr (strcat fltr (vla-get-Name blk) ","))
   )
 )
 (if (ssget "_X" (list (cons 0 "INSERT") (cons 2 fltr)))
   (progn
     (vlax-for	xr (setq ss (vla-get-ActiveSelectionSet *acdoc*))
(setq blk (vla-Item *blocks* (vla-get-Name xr)))
(if (setq path (findfile (vla-get-Path blk)))
  (progn
    (vla-put-Path blk (RelativePath fold path))
    (vla-Reload blk)
  )
)
     )
     (vla-delete ss)
   )
 )
 (princ)
)

;; GetRelativePath (gile)
;; Retourne le chemin relatif du fichier par rapport au dossier
;;
;; Arguments
;; dir : le chemin complet du dossier
;; file : le chemin complet du fichier

(defun RelativePath (dir file / i)
 (setq dir (strcat (vl-string-right-trim "\\" dir) "\\"))
 (if (/= (strcase (substr dir 1 1)) (strcase (substr file 1 1)))
   file
   (progn
     (while
(and
  (setq i (vl-string-position 92 dir))
  (= (strcase (substr dir 1 (1+ i)))
     (strcase (substr file 1 (1+ i)))
  )
)
 (setq dir  (substr dir (+ 2 i))
       file (substr file (+ 2 i))
 )
     )
     (cond
((= file "") nil)
((= dir "") (strcat ".\\" file))
(T
 (while	(setq i (vl-string-position 92 dir))
   (setq dir  (substr dir (+ 2 i))
	 file (strcat "..\\" file)
   )
 )
)
     )
   )
 )
)

[(gile)]

Une autre version qui attribue un chemin relatif aux xrefs, aux images raster, et aux objets sous-jacents (DWF,PDF,DGN).

 

À utiliser avec prudence, je n'ai pas fait de tests en profondeurs, et j'avais eu des erreurs fatales avec une version en dotNET

 

(defun c:xrel (/ fltr ss blk path)
 (vl-load-com)
 (or *acad* (setq *acad* (vlax-get-acad-object)))
 (or *acdoc* (setq *acdoc* (vla-get-ActiveDocument *acad*)))
 (or *blocks* (setq *blocks* (vla-get-Blocks *acdoc*)))
 (setq	fold (getvar 'dwgprefix)
fltr ""
 )
 (vlax-for blk	*blocks*
   (if	(= (vla-get-IsXref blk) :vlax-true)
     (setq fltr (strcat fltr (vla-get-Name blk) ","))
   )
 )
 (if (ssget "_X" (list (cons 0 "INSERT") (cons 2 fltr)))
   (progn
     (vlax-for	xr (setq ss (vla-get-ActiveSelectionSet *acdoc*))
(setq blk (vla-Item *blocks* (vla-get-Name xr)))
(if (setq path (findfile (vla-get-Path blk)))
  (progn
    (vla-put-Path blk (GetRelativePath fold path))
    (vla-Reload blk)
  )
)
     )
     (vla-delete ss)
   )
 )
 (if (ssget "_X"
     '((0 . "IMAGE"))
     )
   (progn
     (vlax-for	obj (setq ss (vla-get-ActiveSelectionSet *acdoc*))
(vla-put-ImageFile
  obj
  (GetRelativePath (getvar 'dwgprefix) (vla-get-ImageFile obj))
)
     )
     (vla-delete ss)
   )
 )
 (if (ssget "_X"
     '((0 . "DWFUNDERLAY,PDFUNDERLAY,DGNUNDERLAY"))
     )
   (progn
     (vlax-for	obj (setq ss (vla-get-ActiveSelectionSet *acdoc*))
(vla-put-File
  obj
  (GetRelativePath (getvar 'dwgprefix) (vla-get-File obj))
)
     )
     (vla-delete ss)
   )
 )
 (princ)
)

;; GetRelativePath (gile)
;; Retourne le chemin relatif du fichier par rapport au dossier
;;
;; Arguments
;; dir : le chemin complet du dossier
;; file : le chemin complet du fichier

(defun GetRelativePath (dir file / i)
 (setq dir (strcat (vl-string-right-trim "\\" dir) "\\"))
 (if (/= (strcase (substr dir 1 1)) (strcase (substr file 1 1)))
   file
   (progn
     (while
(and
  (setq i (vl-string-position 92 dir))
  (= (strcase (substr dir 1 (1+ i)))
     (strcase (substr file 1 (1+ i)))
  )
)
 (setq dir  (substr dir (+ 2 i))
       file (substr file (+ 2 i))
 )
     )
     (cond
((= file "") nil)
((= dir "") (strcat ".\\" file))
(T
 (while	(setq i (vl-string-position 92 dir))
   (setq dir  (substr dir (+ 2 i))
	 file (strcat "..\\" file)
   )
 )
)
     )
   )
 )
)

[vincentp010]

Salut,

 

sinon il y a plus simple avec la commande REDIR

 

redir * .

[GEGEMATIC]

Salut,

 

sinon il y a plus simple avec la commande REDIR

redir * .

J'ai essayé cette manip, mais ça n'a pas fonctionné (Autocad 2012)

Gégé