CADForums.net

Guest

I can successfully recurse all the xrefs from a main drawing and copy
all the files to a destination folder. However, I can't seem to update
the path to remove the old folder.

This code runs without error but when I open the main file from its new
location the xrefs are still resolved to their original paths.

Sub PackAndGoTest()
PackAndGo ThisDrawing.FullName, "C:\Temp\"
MsgBox "Done"
End Sub

Sub PackAndGo(strDwgFile As String, strDestFolder As String)
Dim dwgX As New AXDBlib.AxDbDocument
Dim oBlkRef As AcadExternalReference
Dim oEnt As AcadEntity
Dim strPath As String
If fs.GetParentFolderName(strDwgFile) & "\" <> strDestFolder Then
fs.CopyFile strDwgFile, strDestFolder, True
Debug.Print "Copying " & strDwgFile & " to " & strDestFolder
strDwgFile = fs.BuildPath(strDestFolder,
fs.GetFileName(strDwgFile))
End If
dwgX.Open strDwgFile
For Each oEnt In dwgX.ModelSpace
If TypeOf oEnt Is AcadExternalReference Then
Set oBlkRef = oEnt
strDwgFile = oBlkRef.Path
If InStr(strDwgFile, "\") > 0 Then
On Error Resume Next
fs.CopyFile strDwgFile, strDestFolder, True
If Err.Number <> 0 Then
Debug.Print "**Could not find xref " & strDwgFile
Exit Sub
Else
Debug.Print "Copying " & strDwgFile & " to " &
strDestFolder
End If
End If
strDwgFile = fs.BuildPath(strDestFolder,
fs.GetFileName(strDwgFile))
oBlkRef.Path = strDwgFile
oBlkRef.Update
dwgX.Save
'recurse in case of nested xrefs
PackAndGo strDwgFile, strDestFolder
End If
Next
End Sub

Any help appreciated

	CADForums.net Forum Index -> VBA	All times are GMT
Page 1 of 1