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
Comments
Post a Comment