Vím že bůžu projít všechny bloky, dokážu i jednotlivé bloky přejmenovat, potíž je v tom, že není možné přejmenovat na stéjné jméno více bloků (typů bloků) tím ho přepsat.

 

Jak na to?

V tomto případě nezabere ani BLOCKREPLACE protože umožní vybrat jen jeden název bloku pro nahrazení a dělat to 1536x …

Vytvořit ručně seznam pro nahrazení tolika bloků asi taky není moc příjemné.

Takže tady je makro pro nahrazení mnoha různých bloků blokem jedním.

Není úplně ošetřeno na chyby a tak postupujte takto:

1. spusťte makro

2. při běhu na obrazovce vyberte bloky, které chcete nahradit (výběr ukončete enter nebo PTM)

3. vyberte blok, kterým chcete vybrané bloky nahradit 

 

Sub Blok2Bloky()
'provede nahrazení vybraných bloků novým blokem
Dim vybránblok As Boolean
Dim aktivobj As AcadEntity
Dim blok2 As AcadEntity
Dim Vklbod(0 To 2) As Double
Dim pomset As AcadSelectionSet
Dim aktset As AcadSelectionSet
Dim bodík As Variant

For Each pomset In ThisDrawing.SelectionSets
    If pomset.Name = "ss1" Then
        pomset.Delete 'čistě pro jistotu, pokud po nějakém zhroucení ještě výběr ss1 existuje
        Exit For
    End If
Next pomset
    Set pomset = ThisDrawing.SelectionSets.Add("ss1") 'čistý výběr
    ThisDrawing.Utility.Prompt "Vyberte bloky pro nahrazení"
    Dim intType(0) As Integer
    Dim varData(0) As Variant
    intType(0) = 0
    varData(0) = "INSERT"
   
    pomset.SelectOnScreen intType, varData
    ThisDrawing.Utility.Prompt ""
   
    vybránblok = False
    Do Until vybránblok
        ThisDrawing.Utility.GetEntity blok2, bodík, "Vyberte blok pro nahrazení vybraných bloků. Blok nesmí být součástí výběru pro nahrazení."
        If StrComp(blok2.ObjectName, "AcDbBlockReference", vbTextCompare) = 0 Then
            vybránblok = True
        Else
            MsgBox "Vybraný objekt není blok! Zkuste výběr znovu", vbOKOnly
            vybránblok = False
        End If
    Loop
For Each aktivobj In pomset

    On Error Resume Next 
    Select Case aktivobj.ObjectName
    Case "AcDbBlockReference"
      Dim br1 As AcadBlockReference
      Dim Novyblk As AcadBlockReference
      Set br1 = aktivobj
      Set Novyblk = ThisDrawing.ModelSpace.InsertBlock(br1.InsertionPoint, blok2.Name, 1, 1, 1, br1.Rotation) 'na původní pozici a se stejnou rotací vloží nový blok
      br1.Delete 'po nahrazení bloku smazat původní blok

    End Select
Next aktivobj
ThisDrawing.SelectionSets("ss1").Delete
End Sub