christian.montagnac
2010-03-11, 05:28 PM
Hi,
My purpose is to remove XREF from multiple AUTOCAD files without having to open them in AUTOCAD (that takes too much time)
Using the following VBA code with ObjectDBX Library (AUTOCAD 2007), it seems impossible to detach (or delete) a XREF block from the Blocks collection even after having previously deleted all the references to the block. Has anyone any idea or suggestion?
In addition:
1) The almost same code in VBA Autocad WITHOUT the ObjectDBX library (replacing ODBX with the Active Document)
-succeeds if references exist in only one layout (fails with ObjectDBX library)
-fails if references exist in multiple layouts (deleting references succeeds but detaching block also fails!)
2) After having removed the references with the ObjectDBX code, opening the file in AUTOCAD removes the block from the blocs collection!!! (but not re-opening it with ObjectDBX Library!) but takes a lot of time!
The Code:
Sub DetachXrefTest()
Dim oLayout As AXDBLIB.AcadLayout
Dim oBlock As AXDBLIB.AcadBlock
Dim oRef As AXDBLIB.AcadExternalReference
Dim oEntity As AXDBLIB.AcadEntity
Dim vFileName As Variant
Dim sXrefToRemove As String
Dim ODBX As ODBXClass
On Error GoTo ErrHandler
Set ODBX = New ODBXClass
vFileName = GetOpenFilename(HWND, , "Fichiers Autocad, *.dwg", , "Sélectionner un fichier", , False)
If IsArray(vFileName) Then
ODBX.OpenFile (vFileName(0))
sXrefToRemove = "Name of the XREF to Remove"
For Each oLayout In ODBX.Layouts
For Each oEntity In oLayout.Block
If TypeOf oEntity Is AcadExternalReference Then
Set oRef = oEntity
If oRef.Name = sXrefToRemove Then
Debug.Print "Deleting "; oRef.Name
oRef.Delete
End If
End If
Next
Next
'At this point no error occured but block sXrefToRemove is
'still present in Blocks collection
'Trying to remove it...
Set oBlock = ODBX.Blocks(sXrefToRemove)
Debug.Print "Detaching "; oBlock.Name
oBlock.Detach '=> ERROR: method detach of object 'IAcadBlock' failed
GoTo SubExit
'Other possibility but with same result
For Each oBlock In ODBX.Blocks 'or ODBX.Database.Blocks
If oBlock.IsXRef Then
If oBlock.Name = sXrefToRemove Then
Debug.Print "Detaching "; oBlock.Name
oBlock.Detach 'Same result at this line
End If
End If
Next
End If
SubExit:
Set oBlock = Nothing
Set oLayout = Nothing
Set oEntity = Nothing
Set oRef = Nothing
Set ODBX = Nothing
Exit Sub
ErrHandler:
Debug.Print "ERROR: "; Err.Description
Resume SubExit
End Sub
'*** EXTRACT OF ODBXClass also usable in all VBA interface (EXCEL VBA, WORD VBA,...) *******
Private AxDbDoc As AXDBLIB.AxDbDocument
Private AcadApp As AcadApplication
Private AcadWasNotRunning As Boolean
Private Sub Class_Initialize()
On Error Resume Next
Set AcadApp = GetObject(, "Autocad.Application")
If Err <> 0 Then 'AUTOCAD is not running
AcadWasNotRunning = True
Err.Clear
Set AcadApp = CreateObject("Autocad.Application") 'Run a new instance of AUTOCAD
AcadApp.Visible = False 'Make it not visible
Else
AcadWasNotRunning = False
End If
On Error GoTo 0
'Get interface object for all ObjectDBX functions and link it with the
'AcadApp instance
Set AxDbDoc = AcadApp.GetInterfaceObject("ObjectDBX.AxDbDocument.17")
End Sub
Private Sub Class_Terminate()
Cleanup
End Sub
Private Sub Cleanup()
On Error Resume Next
Set AxDbDoc = Nothing
If AcadWasNotRunning Then
AcadApp.Quit
End If
Set AcadApp = Nothing
End Sub
Property Get Application() As AcadApplication
Set Application = AcadApp
End Property
'
'ALL ORIGINAL PROPERTIES AND METHODS ARE THEN OVERWRITTEN AS FOLLOW
'
Property Get Blocks() As AXDBLIB.AcadBlocks
Set Blocks = AxDbDoc.Blocks
End Property
Public Function ObjectIdToObject(ObjectID As AXDBLIB.LONG_PTR) As Object
Set ObjectIdToObject = AxDbDoc.ObjectIdToObject(ObjectID)
End Function
Public Sub OpenFile(FileName As String, Optional Password)
Call AxDbDoc.Open(FileName, Password)
End Sub
'
'ETC.....
'
'******** END OF EXTRACT OF MY ODBX Class **************
My purpose is to remove XREF from multiple AUTOCAD files without having to open them in AUTOCAD (that takes too much time)
Using the following VBA code with ObjectDBX Library (AUTOCAD 2007), it seems impossible to detach (or delete) a XREF block from the Blocks collection even after having previously deleted all the references to the block. Has anyone any idea or suggestion?
In addition:
1) The almost same code in VBA Autocad WITHOUT the ObjectDBX library (replacing ODBX with the Active Document)
-succeeds if references exist in only one layout (fails with ObjectDBX library)
-fails if references exist in multiple layouts (deleting references succeeds but detaching block also fails!)
2) After having removed the references with the ObjectDBX code, opening the file in AUTOCAD removes the block from the blocs collection!!! (but not re-opening it with ObjectDBX Library!) but takes a lot of time!
The Code:
Sub DetachXrefTest()
Dim oLayout As AXDBLIB.AcadLayout
Dim oBlock As AXDBLIB.AcadBlock
Dim oRef As AXDBLIB.AcadExternalReference
Dim oEntity As AXDBLIB.AcadEntity
Dim vFileName As Variant
Dim sXrefToRemove As String
Dim ODBX As ODBXClass
On Error GoTo ErrHandler
Set ODBX = New ODBXClass
vFileName = GetOpenFilename(HWND, , "Fichiers Autocad, *.dwg", , "Sélectionner un fichier", , False)
If IsArray(vFileName) Then
ODBX.OpenFile (vFileName(0))
sXrefToRemove = "Name of the XREF to Remove"
For Each oLayout In ODBX.Layouts
For Each oEntity In oLayout.Block
If TypeOf oEntity Is AcadExternalReference Then
Set oRef = oEntity
If oRef.Name = sXrefToRemove Then
Debug.Print "Deleting "; oRef.Name
oRef.Delete
End If
End If
Next
Next
'At this point no error occured but block sXrefToRemove is
'still present in Blocks collection
'Trying to remove it...
Set oBlock = ODBX.Blocks(sXrefToRemove)
Debug.Print "Detaching "; oBlock.Name
oBlock.Detach '=> ERROR: method detach of object 'IAcadBlock' failed
GoTo SubExit
'Other possibility but with same result
For Each oBlock In ODBX.Blocks 'or ODBX.Database.Blocks
If oBlock.IsXRef Then
If oBlock.Name = sXrefToRemove Then
Debug.Print "Detaching "; oBlock.Name
oBlock.Detach 'Same result at this line
End If
End If
Next
End If
SubExit:
Set oBlock = Nothing
Set oLayout = Nothing
Set oEntity = Nothing
Set oRef = Nothing
Set ODBX = Nothing
Exit Sub
ErrHandler:
Debug.Print "ERROR: "; Err.Description
Resume SubExit
End Sub
'*** EXTRACT OF ODBXClass also usable in all VBA interface (EXCEL VBA, WORD VBA,...) *******
Private AxDbDoc As AXDBLIB.AxDbDocument
Private AcadApp As AcadApplication
Private AcadWasNotRunning As Boolean
Private Sub Class_Initialize()
On Error Resume Next
Set AcadApp = GetObject(, "Autocad.Application")
If Err <> 0 Then 'AUTOCAD is not running
AcadWasNotRunning = True
Err.Clear
Set AcadApp = CreateObject("Autocad.Application") 'Run a new instance of AUTOCAD
AcadApp.Visible = False 'Make it not visible
Else
AcadWasNotRunning = False
End If
On Error GoTo 0
'Get interface object for all ObjectDBX functions and link it with the
'AcadApp instance
Set AxDbDoc = AcadApp.GetInterfaceObject("ObjectDBX.AxDbDocument.17")
End Sub
Private Sub Class_Terminate()
Cleanup
End Sub
Private Sub Cleanup()
On Error Resume Next
Set AxDbDoc = Nothing
If AcadWasNotRunning Then
AcadApp.Quit
End If
Set AcadApp = Nothing
End Sub
Property Get Application() As AcadApplication
Set Application = AcadApp
End Property
'
'ALL ORIGINAL PROPERTIES AND METHODS ARE THEN OVERWRITTEN AS FOLLOW
'
Property Get Blocks() As AXDBLIB.AcadBlocks
Set Blocks = AxDbDoc.Blocks
End Property
Public Function ObjectIdToObject(ObjectID As AXDBLIB.LONG_PTR) As Object
Set ObjectIdToObject = AxDbDoc.ObjectIdToObject(ObjectID)
End Function
Public Sub OpenFile(FileName As String, Optional Password)
Call AxDbDoc.Open(FileName, Password)
End Sub
'
'ETC.....
'
'******** END OF EXTRACT OF MY ODBX Class **************