topic Re: X-Ref Relative Path Issue in VBA Forum

X-Ref Relative Path Issue

Anonymous — Fri, 17 Dec 2010 11:05:57 GMT

Hi All,

We are in the process of updating the file structure on the office network, and we are going to have to update the x-refs over 1500 drawings. To avoid any down time where drawings are not available, I have created a VBA function that will loop through all the drawings, dethatch the x-refs and reattach them using the relative path. The code is working as I would expect and is re-mapping the x-refs correctly to the relative path, and I can see that in x-ref manager.

The problem is that all the x-refs are vanishing from the drawing. If I manually attach the x-refs and select relative path it works correctly. I issue only arises when I automate it.

The code is below, could anyone please let me know what I have got wrong or missed.

Thank you for your help as always

Andy

' loop through selection set and find xrefs
    For Each acadBlock In BlockSelSet

        If acadBlock.Name Like strBlCode & "~" & strFlCode & "*" Then
            ' get xref name and detatch
            strXrefName = acadBlock.Name
            ThisDrawing.Blocks.item(strXrefName).Detach

            'insert new xref
            Set acadXref = ThisDrawing.ModelSpace.AttachExternalReference(ThisDrawing.Path & "\" & strXrefName & ".dwg", strXrefName, insPnt, 1, 1, 1, 0, True)

          End If

    Next acadBlock

    ThisDrawing.Regen acAllViewports

Re: X-Ref Relative Path Issue

Anonymous — Fri, 17 Dec 2010 14:07:33 GMT

you dont have to detach the xref.

Dim DefBloc As AcadBlock

For Each acadBlock In BlockSelSet

set DefBloc = ThisDrawing.Blocks(acadBlock.Name)

If DefBloc.IsXRef Then '--> xref

defbloc.path = "..\..\aaa\" '<-- here the new path (relative or not)

defbloc.update

      End If

    Next acadBlock

    ThisDrawing.Regen acAllViewports

so i think you need to unlock the layer before doing this. (layer.lock = false / true)

sorry i am bad in english

Re: X-Ref Relative Path Issue

Anonymous — Fri, 17 Dec 2010 15:05:34 GMT

Hi, thank you for you reply, but I get a run time error when i try to run the code like that.

Re: X-Ref Relative Path Issue

Anonymous — Mon, 20 Dec 2010 11:51:41 GMT

Here the full prog.

just copy and past in vba

run the macro : Procgen

Sorry it is in french. But if you need explain i can for you 🙂

you just need to replace "c:\" with the path of your bloc XREF.

etap :

1 - find all the bloc INSERT

2 - test if the bloc is a Xref. (isXref)

3 -if it is so check the bloc def in database (.block())

4 - rename the path with : "c:\" + Name of block + ".dwg"

5 - update the bloc.

6 - end

you just need to save the file , close and reopen --> xref updated !!

i am tested this and it works. (iam under acad 2009)

(it work if you name of bloc = name of file.)

bye

'**********************************************************************
'*** function de sélection selon des critères**************************
'**********************************************************************
' ENTREE :
'   Nom de la sélection
'   Liste de format :
'   ex : (0 , "INSERT", 2, "POSTE") Toujours par 2 : CODE DXF, TYPE RECHERCHE
';**********************************************************************
Public Function SelectAll(NomSelection As String, ParamArray Element()) As Variant
ReDim FiltreT(0 To ((UBound(Element) - 1) / 2)) As Integer     '--> conteneur Type de filtre
Dim FilterType As Variant         '--> Type de filtre ex 0 : filtre sur le type d'objet
ReDim FiltreD(0 To ((UBound(Element) - 1) / 2)) As Variant       '--> conteneur Nom de l'objet
Dim FilterData As Variant         '--> nom de l'objet pour le filtre
Dim index As Integer

Dim Selection As AcadSelectionSet

Dim erreur As Long
index = 0
If NomSelection = "" Then NomSelection = "SelectionAuto"
On Error Resume Next
Set Selection = ThisDrawing.SelectionSets.Add(NomSelection)
If Err.Number <> 0 Then
    Set Selection = ThisDrawing.SelectionSets(NomSelection)
End If
Selection.Delete
Set Selection = ThisDrawing.SelectionSets.Add(NomSelection)
On Error GoTo 0

index = 0
While index < UBound(Element)
    FiltreT(index \ 2) = Element(index)
    FiltreD(index \ 2) = Element(index + 1)
    index = index + 2
Wend
FilterType = FiltreT
FilterData = FiltreD
Selection.Select acSelectionSetAll, , , FilterType, FilterData

Set SelectAll = Selection

End Function

Public Sub Procgen()

Dim OkErreur As Boolean           '--> Retour de la fonction si erreur (=1)
OkErreur = False

Dim ListBloc As AcadSelectionSet      '--> liste des éléments d'un sélection
Dim Bloc As Variant                   '--> boucle sur les sélections
Dim DefBloc As AcadBlock              '--> Référence de l'insertion du bloc

'===========================================
'===== récuperation des blocs "INSERT" =====
'===========================================
Set ListBloc = SelectAll("CHANGEXREF", 0, "INSERT")

'===========================================
'======= Boucle sur chaque élément =========
'===========================================
For Each Bloc In ListBloc 'pour chaque bloc dans la sélection (dans le dessin)
   Set DefBloc = ThisDrawing.Blocks(Bloc.Name)
   If DefBloc.IsXRef Then '--> c'est un xref
      OkErreur = BoucleRechargeXref(Bloc) '--> Récursivité <--
      If OkErreur Then
        Exit For
      End If
   End If 'si c'est un xref
Next
If OkErreur Then
   MsgBox MessageErreurXref, vbCritical + vbOKOnly, "Erreur XRefChange"
End If

End Sub

Private Function BoucleRechargeXref(InsertBloc As Variant) As Boolean
Dim OkErreur As Boolean           '--> Retour de la fonction si erreur (=1)
OkErreur = False

Dim Ok As Boolean
Ok = False

Dim RetourChariot As String
RetourChariot = Chr(13) + Chr(10)

Dim ListBloc As AcadSelectionSet
Dim Bloc As Variant                   '--> boucle sur les sélection
Dim DefBlocXRef As AcadExternalReference '--> définition du bloc ou du xref
Dim DefBloc As AcadBlock              '--> Référence de l'insertion du bloc
Dim RepDessin As String               '--> répertoire du dessin en cours
Dim RepXRefOld As String              '--> répertoire du Xref trouvé (ancien)
Dim RepXRefTrouver As String          '--> répertoire du XRef trouvé (nouveau)

Dim OkMaJ As Boolean                  '--> la mise à jour du Répertoire est OK
OkMaJ = False

'===========================================
'====== Traitement du Bloc Xref ============
'===========================================
Set DefBlocXRef = InsertBloc
RepXRefOld = DefBlocXRef.Path
Set DefBloc = ThisDrawing.Blocks(InsertBloc.Name)

RepDessin = ThisDrawing.GetVariable("DWGPREFIX")
ThisDrawing.Utility.Prompt RetourChariot + Separateur + "Xref trouvé : " + DefBlocXRef.Name
ThisDrawing.Utility.Prompt RetourChariot + Separateur + "-->Rep : " + RepertoireXRef
RepXRefTrouver = "c:\" & DefBloc.Name & ".dwg"
'===========================================
'===Mise à jour du répertoire ==============
'===========================================
If RepXRefTrouver <> "" Then '--- Ok trouver alors mise à jour -----
    OkMaJ = True
    DefBlocXRef.Path = RepXRefTrouver
    DefBlocXRef.Update
Else
    OkErreur = True
    MessageErreurXref = "Répertoire introuvable : " + RetourChariot + _
                        RepXRefOld + RetourChariot + _
                        "pour l'xref : " + DefBlocXRef.Name + RetourChariot + _
                        String(Len(ThisDrawing.GetVariable("DWGPREFIX")) + 20, "=") + RetourChariot + _
                        "dans le fichier : " + ThisDrawing.GetVariable("DWGNAME") + RetourChariot + _
                        "Répertoire : " + ThisDrawing.GetVariable("DWGPREFIX")

End If

ThisDrawing.Utility.Prompt RetourChariot
BoucleRechargeXref = OkErreur
End Function

Re: X-Ref Relative Path Issue

Anonymous — Mon, 20 Dec 2010 16:57:13 GMT

Nice one, thanks. That did the trick.

Here is the working code if anyone ever needs it.

Function DWG_UpdateXref()

    Dim FilterType(1) As Integer
    Dim FilterData(1) As Variant
    Dim BlockSelSet As AcadSelectionSet
    Dim acadBlock As AcadBlockReference
    Dim acadXref As AcadExternalReference
    Dim strBlCode As String
    Dim strFlCode As String
    Dim insPnt(0 To 2) As Double
    Dim strXrefName As String

If Not ThisDrawing.Name Like "*AFM*" Then Exit Function

    On Error Resume Next

    'Set global veriables
    If strDwgType = "" Then SetGlobalVar

    ' get building/floor codes
    strBlCode = GetBuildingCode(ThisDrawing.Name)
    strFlCode = GetFloorCode(ThisDrawing.Name)

    ' set insertion point
    insPnt(0) = 0: insPnt(1) = 0: insPnt(2) = 0

    ' create selection set
    FilterType(0) = 8: FilterData(0) = "0"
    FilterType(1) = 0: FilterData(1) = "INSERT"

Retry:
    Err.Clear
    Set BlockSelSet = ThisDrawing.SelectionSets.Add("xRef")
    If UCase(Err.Description) Like "*SELECTION*" Then
        For Each BlockSelSet In ThisDrawing.SelectionSets
            If BlockSelSet.Name = "xRef" Then
                BlockSelSet.Delete
                Err.Clear
                GoTo Retry
            End If
        Next BlockSelSet
    End If
    BlockSelSet.Select acSelectionSetAll, , , FilterType, FilterData

    On Error GoTo 0

    ' loop through selection set and find xrefs
    For Each acadBlock In BlockSelSet

        If acadBlock.Name Like strBlCode & "~" & strFlCode & "*" Then
            ' get xref name and detatch
            strXrefName = acadBlock.Name
            Set acadXref = ThisDrawing.HandleToObject(acadBlock.Handle)
            acadXref.Path = "..\" & strXrefName & ".dwg"
            acadXref.Update

        ElseIf acadBlock.Name Like "EUR-TITLE-*" Then
            ' do the same with the titlesheet
            strXrefName = acadBlock.Name
            Set acadXref = ThisDrawing.HandleToObject(acadBlock.Handle)
            acadXref.Path = "..\" & strXrefName & ".dwg"
            acadXref.Update
        End If

    Next acadBlock

    ThisDrawing.Regen acAllViewports

End Function