chmtc94
11.03.2010, 17:25
Hi,
Using the following VBA code with ObjectDBX Library, 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 same code WITHOUT the ObjectDBX library
-succeeds if references exist in only one layout (fails with ObjectDBX library)
-fails if references exist in mulriple layouts
2) After having removed the references with this code, opening the file in AUTOCAD removes the block from the blocs collection!!! (but not re-opening it with ObjectDBX Library!)
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 ODBX As ODBXClass '*** SUMMARY 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 OVERWRITED 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 SUMMARY OF MY ODBX Class **************
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... ODBX.Blocks(sXrefToRemove).Detach '=> ERROR: method detach of object 'IAcadBlock' failed GoTo SubExit 'Other possibility but with same result For Each oBlock In ODBX.Blocks If oBlock.IsXRef Then 'Debug.Print oBlock.Name If oBlock.Name = sXrefToRemove Then Debug.Print "Detaching "; oBlock.Name oBlock.Detach 'Same result at this line End If End If Next End IfSubExit: Set oBlock = Nothing Set oLayout = Nothing Set oEntity = Nothing Set oRef = Nothing Set ODBX = Nothing Exit SubErrHandler: Debug.Print "ERROR: "; Err.Description Resume SubExitEnd Subchmtc942010-03-11 17:30:25
Using the following VBA code with ObjectDBX Library, 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 same code WITHOUT the ObjectDBX library
-succeeds if references exist in only one layout (fails with ObjectDBX library)
-fails if references exist in mulriple layouts
2) After having removed the references with this code, opening the file in AUTOCAD removes the block from the blocs collection!!! (but not re-opening it with ObjectDBX Library!)
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 ODBX As ODBXClass '*** SUMMARY 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 OVERWRITED 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 SUMMARY OF MY ODBX Class **************
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... ODBX.Blocks(sXrefToRemove).Detach '=> ERROR: method detach of object 'IAcadBlock' failed GoTo SubExit 'Other possibility but with same result For Each oBlock In ODBX.Blocks If oBlock.IsXRef Then 'Debug.Print oBlock.Name If oBlock.Name = sXrefToRemove Then Debug.Print "Detaching "; oBlock.Name oBlock.Detach 'Same result at this line End If End If Next End IfSubExit: Set oBlock = Nothing Set oLayout = Nothing Set oEntity = Nothing Set oRef = Nothing Set ODBX = Nothing Exit SubErrHandler: Debug.Print "ERROR: "; Err.Description Resume SubExitEnd Subchmtc942010-03-11 17:30:25