AutoCAD VBA Rename blocks to conform and wblock them out

 

Attribute VB_Name = "BlockRenameFormat" Option Explicit Sub REFORMAT_BLOCKNAME() Dim re As New RegExp Dim objBlk As AcadBlock Dim objMc As MatchCollection Dim objSM As SubMatches Dim strName As String Dim objBlk2 As AcadBlock Dim I, ict As Integer ''match the junbk names we have 're.Pattern = "(\d{1,2})[\W\+]{1,}(B[dr])[\W\+]{1,}([a-z]{0,}){0,1}[\W\+]{0,}(\d{3,4})[\W\+]{0,}(SF){0,1}" ''re.Pattern = "(\d{1,2})[\s]{0,}(B[dr])[\s]{0,}([a-z]{0,}){0,1}[\s]{0,}(\d{3,4}){0,1}[\s]{0,}(SF){0,1}" re.Pattern = "(\d{1,2})[\s]{0,}B[dr][\s]{0,}([a-z]{0,}){0,1}[\s]{0,}(\d{3,4}){0,1}[\s]{0,}(?:SF){0,1}" re.IgnoreCase = True re.Multiline = False For Each objBlk In ThisDrawing.Blocks If re.Test(objBlk.Name) Then ''match regex filter Set objMc = Nothing: Set objSM = Nothing: strName = "" Set objMc = re.Execute(objBlk.Name) Set objSM = objMc.Item(0).SubMatches strName = objSM(0) & "-BR" If objSM(1) > "" Then strName = strName & "-" & objSM(1) If objSM(2) > "" Then strName = strName & "-" & Right("000" & objSM(2), 4) & "SF" ict = 0 ''count of similar named blocks For I = 0 To ThisDrawing.Blocks.Count - 1 ''IF LIKE NAME(*) BUT NOT BLOCK NAME=NAME (SAME NAME) If ThisDrawing.Blocks(I).Name Like strName & "*" _ Then ict = ict + 1 End If Next I If ict > 0 And objBlk.Name <> strName Then ''MORE THAN 1 BLOCK NAMD AN DNOT IDENTICAL TO STRNAME objBlk.Name = strName & "(" & ict & ")" ''appent (#) to block name for duplicates Else If ict = 0 Then objBlk.Name = strName End If End If SaveBlockToDisk strName, "C:\KTGY-Revit2019Projects\MillPondSiteStudy\AutoCAD" End If Next objBlk End Sub Sub SaveBlocksMatching() Dim re As New RegExp Dim objBlk As AcadBlock Dim objMc As MatchCollection Dim objSM As SubMatches Dim strName As String Dim objBlk2 As AcadBlock Dim I, ict As Integer ''match the junbk names we have re.Pattern = "\d\-BR\-.*\d{3,4}SF" re.IgnoreCase = True re.Multiline = False For Each objBlk In ThisDrawing.Blocks If re.Test(objBlk.Name) Then ''match regex filter SaveBlockToDisk objBlk.Name, "C:\KTGY-Revit2019Projects\MillPondSiteStudy\AutoCAD\" End If Next objBlk End Sub Public Sub SaveBlockToDisk(BlockName As String, FilePath As String) Dim Block As AcadBlock Dim BlockRef As AcadBlockReference Dim Sset As AcadSelectionSet Dim Point(0 To 2) As Double For Each Block In ThisDrawing.Blocks If Block.Name = BlockName Then 'create insertion Point Point(0) = 0: Point(1) = 0: Point(2) = 0 'insert the Block Set BlockRef = ThisDrawing.ModelSpace.InsertBlock(Point, BlockName, 1#, 1#, 1#, 0#) 'refresh Application Application.Update 'create a selection set object Set Sset = ThisDrawing.SelectionSets.Add("Temp") 'add the block to the selection set Sset.Select acSelectionSetLast 'write the block to File ThisDrawing.Wblock FilePath & BlockName & ".dwg", Sset 'delete the temporary block reference BlockRef.Delete 'delete the selection set Sset.Delete 'refresh Application Application.Update End If Next Block End Sub Private Sub Test() SaveBlockToDisk "Block1", "C:\" End Sub