Changing an xref path - the whole path??

I've been searching on this for days and I've found many helpful and diverse ways to identify xrefs, detach them, attach them and to identify the file name.

What I can't seem to figure out is how to get the preceeding directory structure aka the entire path. Does anyone have a snippet that will show me what I need to do to get the entire path? I've read the issue may be that you have to get the path from the XREF OBJECT, not the BLOCK OBJECT. How would one go about that?

Here's what I've been working with so far (I believe it came from Gordon Price):

Dim oXref As AcadExternalReference

Private Sub CommandButton1_Click()
GetXrefPathByBlockName ("fptcprfapm") ' This is an example xref I have attached to my drawing. "X:\TEST\Subfolder\fptcprfapm.dwg"
Label1.Caption = oXref.Path ' This just returns "ftpcprfapm.dwg"
End Sub

Public Function GetXrefPathByBlock(oBlock As AcadBlock) As String
'returns the path of the xref
Dim oXref As AcadExternalReference
Dim obj As Object
If oBlock.IsXRef Then
For Each obj In ThisDrawing.ModelSpace
If TypeOf obj Is AcadExternalReference Then
Set oXref = obj
If oXref.Name = oBlock.Name Then
GetXrefPathByBlock = oXref.Path
End If
End If
Next obj
For Each obj In ThisDrawing.PaperSpace
If TypeOf obj Is AcadExternalReference Then
Set oXref = obj
If oXref.Name = oBlock.Name Then
GetXrefPathByBlock = oXref.Path
End If
End If
Next obj
Else
GetXrefPathByBlock = ""
End If

End Function

Public Function GetXrefPathByBlockName(BlockName As String) As String
'returns the path of the xref

Dim obj As Object
For Each obj In ThisDrawing.ModelSpace
If TypeOf obj Is AcadExternalReference Then
Set oXref = obj
If oXref.Name = BlockName Then
GetXrefPathByBlockName = oXref.Path
Else
GetXrefPathByBlockName = ""
End If
End If
Next obj
For Each obj In ThisDrawing.PaperSpace
If TypeOf obj Is AcadExternalReference Then
Set oXref = obj
If oXref.Name = BlockName Then
GetXrefPathByBlockName = oXref.Path
Else
GetXrefPathByBlockName = ""
End If
End If
Next obj

End Function

Public Function vbdPowerSet(strName As String) As AcadSelectionSet
Dim objSelSet As AcadSelectionSet
Dim objSelCol As AcadSelectionSets
Set objSelCol = ThisDrawing.SelectionSets
For Each objSelSet In objSelCol
If objSelSet.Name = strName Then
objSelCol.Item(strName).Delete
Exit For
End If
Next
Set objSelSet = objSelCol.Add(strName)
Set vbdPowerSet = objSelSet
End Function

 

Try this...

Code:

Option Explicit

Sub Test()
Dim objEnt As AcadEntity
Dim objXref As AcadExternalReference
For Each objEnt In ThisDrawing.ModelSpace
If TypeOf objEnt Is AcadExternalReference Then
Set objXref = objEnt
MsgBox GetFileParts(objXref.Path, 0) &
GetFileParts(objXref.Path, 1)
End If
Next objEnt
End Sub

Public Function GetFileParts(ByVal TempPath As String, ReturnType As
Integer)
Dim DriveLetter As String
Dim DirPath As String
Dim FName As String
Dim Extension As String
Dim PathLength As Integer
Dim ThisLength As Integer
Dim Offset As Integer
Dim FileNameFound As Boolean

If ReturnType <> 0 And ReturnType <> 1 And ReturnType <> 2 And
ReturnType <> 3 Then
Err.Raise 1
Exit Function
End If

DriveLetter = ""
DirPath = ""
FName = ""
Extension = ""

If Mid(TempPath, 2, 1) = ":" Then ' Find the drive letter.
DriveLetter = Left(TempPath, 2)
TempPath = Mid(TempPath, 3)
End If

PathLength = Len(TempPath)

For Offset = PathLength To 1 Step -1 ' Find the next delimiter.
Select Case Mid(TempPath, Offset, 1)
Case ".": ' This indicates either an extension or a . or a ..
ThisLength = Len(TempPath) - Offset
If ThisLength >= 1 Then ' Extension
Extension = Mid(TempPath, Offset, ThisLength + 1)
End If
TempPath = Left(TempPath, Offset - 1)
Case "\": ' This indicates a path delimiter.
ThisLength = Len(TempPath) - Offset
If ThisLength >= 1 Then ' Filename
FName = Mid(TempPath, Offset + 1, ThisLength)
TempPath = Left(TempPath, Offset)
FileNameFound = True
Exit For
End If
Case Else
End Select

Next Offset

If FileNameFound = False Then
FName = TempPath
Else
DirPath = TempPath
End If

If ReturnType = 0 Then
GetFileParts = DriveLetter
ElseIf ReturnType = 1 Then
GetFileParts = DirPath
ElseIf ReturnType = 2 Then
GetFileParts = FName
ElseIf ReturnType = 3 Then
GetFileParts = Extension
End If
End Function

--
I support two teams: The Red Sox and whoever beats the Yankees.

I've been searching on this for days and I've found many helpful and diverse
ways to identify xrefs, detach them, attach them and to identify the file
name.

What I can't seem to figure out is how to get the preceeding directory
structure aka the entire path. Does anyone have a snippet that will show me
what I need to do to get the entire path? I've read the issue may be that
you have to get the path from the XREF OBJECT, not the BLOCK OBJECT. How
would one go about that?

Here's what I've been working with so far (I believe it came from Gordon
Price):

Dim oXref As AcadExternalReference

Private Sub CommandButton1_Click()
GetXrefPathByBlockName ("fptcprfapm") ' This is an example xref I have
attached to my drawing. "X:\TEST\Subfolder\fptcprfapm.dwg"
Label1.Caption = oXref.Path ' This just returns
"ftpcprfapm.dwg"
End Sub

Public Function GetXrefPathByBlock(oBlock As AcadBlock) As String
'returns the path of the xref
Dim oXref As AcadExternalReference
Dim obj As Object
If oBlock.IsXRef Then
For Each obj In ThisDrawing.ModelSpace
If TypeOf obj Is AcadExternalReference Then
Set oXref = obj
If oXref.Name = oBlock.Name Then
GetXrefPathByBlock = oXref.Path
End If
End If
Next obj
For Each obj In ThisDrawing.PaperSpace
If TypeOf obj Is AcadExternalReference Then
Set oXref = obj
If oXref.Name = oBlock.Name Then
GetXrefPathByBlock = oXref.Path
End If
End If
Next obj
Else
GetXrefPathByBlock = ""
End If

End Function

Public Function GetXrefPathByBlockName(BlockName As String) As String
'returns the path of the xref

Dim obj As Object
For Each obj In ThisDrawing.ModelSpace
If TypeOf obj Is AcadExternalReference Then
Set oXref = obj
If oXref.Name = BlockName Then
GetXrefPathByBlockName = oXref.Path
Else
GetXrefPathByBlockName = ""
End If
End If
Next obj
For Each obj In ThisDrawing.PaperSpace
If TypeOf obj Is AcadExternalReference Then
Set oXref = obj
If oXref.Name = BlockName Then
GetXrefPathByBlockName = oXref.Path
Else
GetXrefPathByBlockName = ""
End If
End If
Next obj

End Function

Public Function vbdPowerSet(strName As String) As AcadSelectionSet
Dim objSelSet As AcadSelectionSet
Dim objSelCol As AcadSelectionSets
Set objSelCol = ThisDrawing.SelectionSets
For Each objSelSet In objSelCol
If objSelSet.Name = strName Then
objSelCol.Item(strName).Delete
Exit For
End If
Next
Set objSelSet = objSelCol.Add(strName)
Set vbdPowerSet = objSelSet
End Function

 

No, that may not work in 2004+ because of how xrefing has changed to use
relative pathing so your objXref.Path will still pull a blank string. The
reason is because the xref is not "found" - it is locaed in the same
directory or a sub directory. The only sure way is to use FileDependencies.

Also, I wouldn't use either of you two code samples. Both of you are
iterating EVERY item in model space which could be time consuming - learn
to use a filtered selection set [where are ou, Bobby? =)] While this
approach is much debated, it works the best on large files. You know how
big your files are so use your best judgement.

Below is sample code. Just create a new project, add a form with a combobox
and a label. When the xref in the combo is selected, the fullname will be
placed into the label. From there, you can parse the path out.

Pause the code as it runs and pay attention to the oFD - filedependency -
and its FullFileName and Found properties.

-- Mike
___________________________
Mike Tuersley
CADalyst's CAD Clinic
Rand IMAGINiT Technologies
___________________________
the trick is to realize that there is no spoon...


{BEGIN CODE]
Option Explicit

Private Sub ComboBox1_Change()
Dim oFD As AcadFileDependency
For Each oFD In ThisDrawing.FileDependencies
If oFD.Feature = "Acad:XRef" Then
If oFD.FileName = ComboBox1.Text & ".dwg" Then
If oFD.FoundPath <> vbNullString Then
Label1.Caption = oFD.FoundPath
Else
If oFD.FullFileName <> vbNullString Then
Label1.Caption = oFD.FullFileName
Else
Label1.Caption = "no path found"
End If
End If
Exit For
End If
End If
Next
Set oFD = Nothing
End Sub

Private Sub UserForm_Initialize()
Dim oXRef As AcadExternalReference
Dim sXrefs As AcadSelectionSet
Set sXrefs = GetXRefs
If Not sXrefs Is Nothing Then
For Each oXRef In sXrefs
ComboBox1.AddItem oXRef.Name
Next
End If
If Not oXRef Is Nothing Then Set oXRef = Nothing
If Not sXrefs Is Nothing Then
sXrefs.Delete
Set sXrefs = Nothing
End If
End Sub

Private Function GetXRefs() As AcadSelectionSet
Dim lCntr As Long
Dim iCode() As Integer
Dim vValue() As Variant
Dim oblk As AcadBlock
Dim cXRefs As Collection
Dim ssXRefs As AcadSelectionSet

Set cXRefs = New Collection

'iterate blocks looking for xrefs
On Error Resume Next
For Each oblk In ThisDrawing.Blocks
If oblk.IsXRef = True Then
cXRefs.Add (oblk.Name)
If Err.Number <> 0 Then Err.Clear
End If
Next
On Error GoTo 0

If cXRefs.Count > 0 Then

ReDim iCode(cXRefs.Count + 2)
ReDim vValue(cXRefs.Count + 2)

'start the filter
iCode(0) = 0: vValue(0) = "INSERT"
iCode(1) = -4: vValue(1) = "<OR"
'iterate our collection and add the block
'names to the search criteria
For lCntr = 1 To cXRefs.Count
iCode(lCntr + 1) = 2: vValue(lCntr + 1) = cXRefs(lCntr)
Next
'end the filter
iCode(lCntr + 1) = -4: vValue(lCntr + 1) = "OR>"
'select them
On Error Resume Next
Set ssXRefs = ThisDrawing.SelectionSets.Add("ssXrefs")
If Err.Number <> 0 Then
Err.Clear
ThisDrawing.SelectionSets("ssXrefs").Delete
Set ssXRefs = ThisDrawing.SelectionSets.Add("ssXrefs")
End If

On Error GoTo 0

ssXRefs.Select acSelectionSetAll, , , iCode, vValue

If ssXRefs.Count > 0 Then
Set GetXRefs = ssXRefs
Else
Set GetXRefs = Nothing
End If

Else
Set GetXRefs = Nothing
End If

If Not oblk Is Nothing Then Set oblk = Nothing
If Not cXRefs Is Nothing Then Set cXRefs = Nothing
If Not ssXRefs Is Nothing Then Set ssXRefs = Nothing

End Function
[END CODE]

 

LOL! I see that I've garnered a reputation <g>
Just for the record, I'm not completely anti-selection sets. I'm just
opposed to the exclusive use of them when cleaner code serves the same
purpose.
--
Bobby C. Jones

 

BTW - I wouldn't change from the nice clean

For Each entity In ...
If TypeOf entity Is ...
...
End If
Next ...

to using a selection set unless actual testing showed that this particular
section of code didn't meet acceptable performance criteria.

I figured that I had better state that or else my reputation might get
tarnished!

BTW - I was rather dissapointed that I didn't see you this year at AU Mike
:-(

 

Yeah, not half as much as I was! We're still too short staffed and projects
take priority - or so I'm told ;-) I'll be there this year and the first
round is on me!

-- Mike
___________________________
Mike Tuersley
CADalyst's CAD Clinic
Rand IMAGINiT Technologies
___________________________
the trick is to realize that there is no spoon...

 

Thanks Matt! That got me back on track!