Updat/Replace a block in group of dwgs in a folder without manually opening
Here's the VBA routine I was speaking about.
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" 'folder of the base file
dir2 = "C:\User\AutoCAD files\folder2" 'folder of the target files
Dim TrgtFo As Folder, BaseFile As File, TrgtFile As File
Set TrgtFo = FSO.GetFolder(dir2)
'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.
BaseFilename = "basefile.dwg" '<<rename it to the actual base file name>>
BaseFilepath = dir1 & "\" & BaseFilename
For Each TrgtFile In TrgtFo.Files
TrgtFilename = TrgtFile.name
If Right(TrgtFilename, 4) = ".dwg" Then
TrgtFilepath = dir2 & "\" & TrgtFilename
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/8216368#M373026
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 TrgtFile
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 SubTo make it work:
- The directory paths must be modified to your working paths.
you can find and replace them here'<<Replace these directories to the actual ones of folder 1 & folder 2>> dir1 = "C:\User\AutoCAD files\folder1" 'folder of the base file dir2 = "C:\User\AutoCAD files\folder2" 'folder of the target filesand hereBaseFilename = "basefile.dwg" '<<rename it to the actual base file name>>
- Make sure these reference files are added, you can do that at the visual basic editor from Tools>References
