For all files in folder, replace block from a identically named drawing
The best I could accomplish until now is to copy "exploded" blocks from drawing1 to drawing2 onto their insertion points in drawing2.
Sadly, Wblock was useless with every attempt, CopyObjects doesn't affect block definition, and the block object (within AutoCAD's "documented" object model) doesn't expose any method to add multiple objects like the BEDIT command.
________________
Anyway, here's the reference files to the macro
And Here's the Code
Public FSO As New FileSystemObject
'The Fucntion ((ExplodeEX)) is written by Randal Rath
'The Source is from this URL:-
' https://forums.autodesk.com/t5/visual-basic-customization/explode-method-in-vba/m-p/336502#M28390
'This Function is used instead of the "Explode" method, that's because it doesn't work with blocks (undocumented issue)
Public Function ExplodeEX(oBlkRef As AcadBlockReference, _
bKeep As Boolean) As Variant
Dim objEnt As AcadEntity
Dim objMT As AcadMText
Dim objBlk As AcadBlock
Dim objDoc As AcadDocument
Dim objArray() As AcadEntity
Dim objSpace As AcadBlock
Dim intCnt As Integer
Dim varTemp As Variant
Dim varPnt As Variant
Dim dblScale As Double
Dim dblRot As Double
Dim dblMatrix(3, 3) As Double
On Error GoTo Err_Control
'What document is the reference in?
Set objDoc = oBlkRef.Document
'Model space or layout?
Set objSpace = objDoc.ObjectIdToObject(oBlkRef.OwnerID)
Set objBlk = objDoc.Blocks(oBlkRef.name)
varPnt = oBlkRef.InsertionPoint
dblScale = oBlkRef.XScaleFactor
dblRot = oBlkRef.Rotation
'Set the matrix for new objects transform
'*Note:
'This matrix uses only the X scale factor of the
'Block reference, many entities can not be scaled
'Non-uniformly!
dblMatrix(0, 0) = dblScale
dblMatrix(0, 1) = 0
dblMatrix(0, 2) = 0
dblMatrix(0, 3) = varPnt(0)
dblMatrix(1, 0) = 0
dblMatrix(1, 1) = dblScale
dblMatrix(1, 2) = 0
dblMatrix(1, 3) = varPnt(1)
dblMatrix(2, 0) = 0
dblMatrix(2, 1) = 0
dblMatrix(2, 2) = dblScale
dblMatrix(2, 3) = varPnt(2)
dblMatrix(3, 0) = 0
dblMatrix(3, 1) = 0
dblMatrix(3, 2) = 0
dblMatrix(3, 3) = 1
'Get all of the entities in the block
ReDim objArray(objBlk.Count - 1)
For Each objEnt In objBlk
Set objArray(intCnt) = objEnt
intCnt = intCnt + 1
Next objEnt
'Place them into the correct space
varTemp = objDoc.CopyObjects(objArray, objSpace)
'Transform & rotate
For intCnt = LBound(varTemp) To UBound(varTemp)
Set objEnt = varTemp(intCnt)
objEnt.TransformBy dblMatrix
objEnt.Rotate varPnt, dblRot
Next intCnt
'Keep the block reference?
If Not bKeep Then
oBlkRef.Delete
End If
'Return all of the new entities
ExplodeEX = varTemp
'Release memory
Set objDoc = Nothing
Set objBlk = Nothing
Set objSpace = Nothing
Exit_Here:
Exit Function
Err_Control:
MsgBox Err.Description
Resume Exit_Here
End Function
'The Subroutine BlockReplace is written by Serag Hassouna
'The Commented Codes belong to the unsuccessfull trials, they're left for reference
Sub BlockReplace()
'Get the Application object
Dim acad As AcadApplication
Set acad = GetObject(, "AutoCAD.Application.20")
'Get the Documents Collection
Dim docs As AcadDocuments
Set docs = acad.Documents
'Get folders' directories
Dim dir1 As String, dir2 As String
'<<Replace these directories to the actual ones of folder 1 & folder 2>>
dir1 = "C:\User\AutoCAD files\folder1"
dir2 = "C:\User\AutoCAD files\folder2"
Dim BaseFo As Folder, BaseFile As File, TrgtFile As File
Set BaseFo = FSO.GetFolder(dir1)
'Declare needed variables
Dim BaseFilename As String, BaseFilepath As String, TrgtFilepath As String
Dim BaseDocument As AcadDocument, TrgtDocument As AcadDocument
Dim AllBlockRefs As AcadSelectionSet
Dim gpcode(0) As Integer, datavalue(0) As Variant
gpcode(0) = 0
datavalue(0) = "INSERT"
Dim GroupCode As Variant, dataCode As Variant
GroupCode = gpcode
dataCode = datavalue
Dim BlockRef As AcadBlockReference, i As Integer, BRefName As String, BRefInsPnt As Variant
Dim BlockAttrs As Variant, BRefInBase As AcadBlockReference
Dim obj() As Variant 'As Object with CopyObjects method, As AcadEntity with single Blocks
Dim TrgtObj() As Variant
' Dim objs() As Object
' Dim ssobjs As AcadSelectionSet
Dim BCount As Integer
Dim j As Integer
'Iterate through the base folder, get the other file that's named the same
'Make a selection set for all block reference objects within the target drawing
'For every block reference, get its name, insertion point and attributes
'The rest are ((trials to copy the block references from base drawing to target drawing))
For Each BaseFile In BaseFo.Files
BaseFilename = BaseFile.name
BaseFilepath = dir1 & "\" & BaseFilename
TrgtFilepath = dir2 & "\" & BaseFilename
Set BaseDocument = docs.Open(BaseFilepath)
Set TrgtDocument = docs.Open(TrgtFilepath)
Set AllBlockRefs = TrgtDocument.SelectionSets.Add("allblockrefs")
'Set ssobjs = BaseDocument.SelectionSets.Add("BlocksToDeliver")
AllBlockRefs.Select acSelectionSetAll, , , GroupCode, dataCode
BCount = AllBlockRefs.Count
ReDim obj(0 To (BCount - 1)) As Variant 'Base objects to be copied, As Object with CopyObjects method
'As AcadEntity with Wblock when they're single Blocks
ReDim TrgtObj(0 To (BCount - 1)) As Variant
'For every target blockref, insert a similar-named block within the base drawing
For i = 0 To (BCount - 1)
Set BlockRef = AllBlockRefs.Item(i)
BRefName = BlockRef.name
BRefInsPnt = BlockRef.InsertionPoint
BlockAttrs = BlockRef.GetAttributes
obj(i) = ExplodeEX(BaseDocument.ModelSpace.InsertBlock(BRefInsPnt, BRefName, 1, 1, 1, 0), False) 'Thanks Randal Rath
' "Set" keyword was used with obj(i) when its data type was Object & AcadEntity
' ssobjs.AddItems obj(i)
' BaseDocument.Wblock TrgtFilepath, ssobjs
TrgtObj(i) = BaseDocument.CopyObjects(obj(i), TrgtDocument.ModelSpace) 'Works with Modelspace, not with any block definition
'TrgtDocument.CopyObjects TrgtObj(i), TrgtDocument.Blocks.Item(BRefName) 'Doesn't Work
' ssobjs.Clear
'Delete the objects resulted from the explosion process
For j = LBound(obj(i)) To UBound(obj(i))
obj(i)(j).Delete
Next j
Next i
' ReDim objs(0 To (BCount - 1)) As Object 'used with CopyObject
' objs = BaseDocument.CopyObjects(obj, TrgtDocument.ModelSpace)
' ssobjs.AddItems obj 'used with Wblock
' BaseDocument.Wblock TrgtFilepath, ssobjs
'Delete blocks from target drawings [not used when incrementing with "Item" method to avoid
'any indexing issues that could result from deletion]
Dim elem As Variant 'any other data type declaration generates an error
For Each elem In AllBlockRefs
elem.Delete
Next elem
BaseDocument.Close False
TrgtDocument.Close True
Next BaseFile
MsgBox "Finished" 'debug line
End Sub
As For a VBA routine, this is the last version that hasn't produced any bug yet as far as I know.
I've posted similar routines but both of them don't work totally as expected.
Public FSO As New FileSystemObject
'The Fucntion ((ExplodeEX)) is written by Randal Rath
'The Source is from this URL:-
' https://forums.autodesk.com/t5/visual-basic-customization/explode-method-in-vba/m-p/336502#M28390
'This Function is used instead of the "Explode" method, that's because it doesn't work with blocks (undocumented issue)
Public Function ExplodeEX(oBlkRef As AcadBlockReference, _
bKeep As Boolean) As Variant
Dim objEnt As AcadEntity
Dim objMT As AcadMText
Dim objBlk As AcadBlock
Dim objDoc As AcadDocument
Dim objArray() As AcadEntity
Dim objSpace As AcadBlock
Dim intCnt As Integer
Dim varTemp As Variant
Dim varPnt As Variant
Dim dblScale As Double
Dim dblRot As Double
Dim dblMatrix(3, 3) As Double
On Error GoTo Err_Control
'What document is the reference in?
Set objDoc = oBlkRef.Document
'Model space or layout?
Set objSpace = objDoc.ObjectIdToObject(oBlkRef.OwnerID)
Set objBlk = objDoc.Blocks(oBlkRef.name)
varPnt = oBlkRef.InsertionPoint
dblScale = oBlkRef.XScaleFactor
dblRot = oBlkRef.Rotation
'Set the matrix for new objects transform
'*Note:
'This matrix uses only the X scale factor of the
'Block reference, many entities can not be scaled
'Non-uniformly!
dblMatrix(0, 0) = dblScale
dblMatrix(0, 1) = 0
dblMatrix(0, 2) = 0
dblMatrix(0, 3) = varPnt(0)
dblMatrix(1, 0) = 0
dblMatrix(1, 1) = dblScale
dblMatrix(1, 2) = 0
dblMatrix(1, 3) = varPnt(1)
dblMatrix(2, 0) = 0
dblMatrix(2, 1) = 0
dblMatrix(2, 2) = dblScale
dblMatrix(2, 3) = varPnt(2)
dblMatrix(3, 0) = 0
dblMatrix(3, 1) = 0
dblMatrix(3, 2) = 0
dblMatrix(3, 3) = 1
'Get all of the entities in the block
ReDim objArray(objBlk.Count - 1)
For Each objEnt In objBlk
Set objArray(intCnt) = objEnt
intCnt = intCnt + 1
Next objEnt
'Place them into the correct space
varTemp = objDoc.CopyObjects(objArray, objSpace)
'Transform & rotate
For intCnt = LBound(varTemp) To UBound(varTemp)
Set objEnt = varTemp(intCnt)
objEnt.TransformBy dblMatrix
objEnt.Rotate varPnt, dblRot
Next intCnt
'Keep the block reference?
If Not bKeep Then
oBlkRef.Delete
End If
'Return all of the new entities
ExplodeEX = varTemp
'Release memory
Set objDoc = Nothing
Set objBlk = Nothing
Set objSpace = Nothing
Exit_Here:
Exit Function
Err_Control:
MsgBox Err.Description
Resume Exit_Here
End Function
'The Subroutine ((BlockReplace)) is written by Serag Hassouna
'The Commented Codes belong to the unsuccessfull trials, they're left for reference
Sub BlockReplace()
'Get the Application object
Dim acad As AcadApplication
Set acad = GetObject(, "AutoCAD.Application.20")
'Get the Documents Collection
Dim docs As AcadDocuments
Set docs = acad.Documents
'Get folders' directories
Dim dir1 As String, dir2 As String
'<<Replace these directories to the actual ones of folder 1 & folder 2>>
dir1 = "C:\User\AutoCAD files\folder1"
dir2 = "C:\User\AutoCAD files\folder2"
Dim BaseFo As Folder, BaseFile As File, TrgtFile As File
Set BaseFo = FSO.GetFolder(dir1)
'Declare needed variables
Dim BaseFilename As String, BaseFilepath As String, TrgtFilepath As String
Dim BaseDocument As AcadDocument, TrgtDocument As AcadDocument
Dim AllBlockRefs As AcadSelectionSet
Dim gpcode(0) As Integer, datavalue(0) As Variant
gpcode(0) = 0
datavalue(0) = "INSERT"
Dim GroupCode As Variant, dataCode As Variant
GroupCode = gpcode
dataCode = datavalue
'Variables for block references in target drawing
Dim BlockRef As AcadBlockReference, BRefName As String, BRefInsPnt As Variant
Dim BCount As Integer
'Variables for the copied objects to the target drawing
Dim obj() As Variant
Dim TrgtObj() As Variant
Dim ssTrgtObj As AcadSelectionSet, DefInsPnt As String
'Variables for block definitions
Dim BDefsStatus() As Variant, BDefStatus(0 To 1) As String, BDefSt As Variant 'is block definition modified?
Dim BDefsCount As Integer
'Variables for incrementation
Dim i As Integer, j As Integer, k As Integer, m As Integer, m2 As Integer
'Iterate through the base folder, get the other file that's named the same
'Make a selection set for all block reference objects within the target drawing
'For every block reference, get its name, insertion point and attributes
'If the corespondant block definition isn't modified, modify it
'by
' 1- insert a block reference in the base drawing onto the corespondant insertion point of the
' the block reference with the target drawing.
' 2- explode the newly inserted block reference in the base drawing.
' 3- copy the explosion objects to the target drawing.
' [an attribute definition was inserted within a block definition in the base
' drawing & was successfully copied to the target drawing]
'Note that modification is done with the "-Block" command
'Finally, insert the modified block into its original insertion point in the target drawing.
For Each BaseFile In BaseFo.Files
BaseFilename = BaseFile.name
If Right(BaseFilename, 4) = ".dwg" Then
BaseFilepath = dir1 & "\" & BaseFilename
TrgtFilepath = dir2 & "\" & BaseFilename
Set BaseDocument = docs.Open(BaseFilepath)
On Error GoTo NoMatchFile:
Set TrgtDocument = docs.Open(TrgtFilepath)
TrgtDocument.Activate
TrgtDocument.SendCommand "(vl-load-com)" & vbCr 'Prepare for blocks redefinition
Set AllBlockRefs = TrgtDocument.SelectionSets.Add("allblockrefs")
Set ssTrgtObj = TrgtDocument.SelectionSets.Add("Block2Define")
AllBlockRefs.Select acSelectionSetAll, , , GroupCode, dataCode
BCount = AllBlockRefs.Count
BDefsCount = BaseDocument.Blocks.Count
ReDim obj(0 To (BCount - 1)) As Variant 'Base objects to be copied, As Object with CopyObjects method
'As AcadEntity with Wblock when they're single Blocks
ReDim TrgtObj(0 To (BCount - 1)) As Variant
ReDim idpairs(0 To (BCount - 1)) As Variant
Dim TrgtObjs() As AcadEntity 'for "Block2Define" Selection Set
ReDim BDefsStatus(0 To BDefsCount) As Variant
On Error Resume Next 'Make the useless "Invalid procedure call or argument" error go away
For m = 0 To BDefsCount
BDefStatus(0) = BaseDocument.Blocks.Item(m).name
BDefStatus(1) = "Not Modified"
BDefsStatus(m) = BDefStatus
Next m
'Define vlaSel->Sel (docks elements in an ActiveX sset to a new ordinary sset)
'vlaSel-> is written by Doaiena
'The replay URL that contains it is:-
' https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/convert-selection-set-s-vla-object-to-ordinary-selection-set/m-p/8216062#M373023
TrgtDocument.Activate
TrgtDocument.SendCommand "(defun vlaSel->Sel ( vlaSel / sel )" & vbLf & _
"(setq sel (ssadd))" & vbLf & _
"(vlax-for obj vlaSel" & vbLf & _
"(ssadd (vlax-vla-object->ename obj) sel)" & vbLf & _
")" & vbLf & _
"sel" & vbLf & _
")" & vbCr
'For every target blockref, insert a similar-named block within the base drawing
For i = 0 To (BCount - 1)
Set BlockRef = AllBlockRefs.Item(i)
BRefName = BlockRef.name
BRefInsPnt = BlockRef.InsertionPoint
DefInsPnt = BRefInsPnt(0) & "," & BRefInsPnt(1) & "," & BRefInsPnt(2)
'get the block definition modification status
For m = 0 To BDefsCount
If BRefName = BDefsStatus(m)(0) Then
BDefSt = BDefsStatus(m)(1)
m2 = m
End If
Next m
'if the block definition isn't modified, modify it and change its modification status
If BDefSt = "Not Modified" Then
BDefsStatus(m2)(1) = "Modified"
obj(i) = ExplodeEX(BaseDocument.ModelSpace.InsertBlock(BRefInsPnt, BRefName, 1, 1, 1, 0), False) 'Thanks Randal Rath
' "Set" keyword was used with obj(i) when its data type was Object & AcadEntity
TrgtObj(i) = BaseDocument.CopyObjects(obj(i), TrgtDocument.ModelSpace, idpairs(i)) 'Works with ModelSpace, not with any block definition
ReDim TrgtObjs(LBound(TrgtObj(i)) To UBound(TrgtObj(i)))
For k = LBound(TrgtObj(i)) To UBound(TrgtObj(i))
Set TrgtObjs(k) = TrgtObj(i)(k)
Next k
ssTrgtObj.AddItems TrgtObjs
'MsgBox ssTrgtObj.Count 'Selection Set works fine
'Delete the objects resulted from the explosion process
For j = LBound(obj(i)) To UBound(obj(i))
obj(i)(j).Delete
Next j
'Redefine block
TrgtDocument.SendCommand "-Block" & vbCr & BRefName & vbCr & "y" & vbCr & DefInsPnt & vbCr & _
"(vlaSel->Sel (vla-item (vla-get-selectionsets (vla-get-activedocument (vlax-get-acad-object))) ""Block2Define""))" _
& vbCr & vbCr
End If
'MsgBox CStr(idpairs(i)) 'debug line
TrgtDocument.ModelSpace.InsertBlock BRefInsPnt, BRefName, 1, 1, 1, 0
ssTrgtObj.Clear
Next i
'Delete blocks from target drawings [not used when incrementing with "Item" method to avoid
'any indexing issues that could result from deletion]
Dim elem As Variant 'any other data type declaration generates an error
For Each elem In AllBlockRefs
elem.Delete
Next elem
BaseDocument.Close False
TrgtDocument.Close True
End If 'for dealing only with .dwg files
Next BaseFile
NoMatchFile:
If Err.Number = -2145320924 Then
MsgBox "Base file " & BaseFilename & " has no target one." & vbLf & "Operation Terminated."
BaseDocument.Close False
End If
Exit Sub
End Sub____________
Don't forget to add needed reference files.
Sorry for getting back to this so late!
I would like to test this but I am having issues with references, here is all I could find:
And I am getting User-Defined type not defined error when trying to run this!
Ok I think I fixed the references, but now this throws me off:
It highlights the set acad = getobject line.
Well, I'm using AutoCAD 2016, Can you tell me the version you're using ?
Also, try to remove the ".20" part from this line & run the code
Set acad = GetObject(, "AutoCAD.Application")
________
To specify the suitable text replacing "AutoCAD.Application.20" please refer to a file named acadauto.chm, search for it into your installation folder.
Here's where I've taken the text that worked for the version I'm using.
