BlocksExplode

Merhaba,

BlocksExplode.bas dosyası yükledikten sonra
BlockPatlat Macrosu çalıştırdığınız da
Sizden çiziminiz de patlatmak istediğiniz blocklardan bir tanesini seçmenizi ister
block seçtiğiniz de aynı blokların hepsini patlatır yani Explode uygular
esc, space veya enter tıklanırsa macro sonlanır

Public Sub BlocksExplode(BlockToFind As String)

Dim fType(0 To 1) As Integer, fData(0 To 1)
Dim BlockSS As AcadSelectionSet
Dim secili As Integer

On Error Resume Next
Set BlockSS = ThisDrawing.SelectionSets("BlockSS")
If Err Then Set BlockSS = ThisDrawing.SelectionSets.Add("BlockSS")
BlockSS.Clear
On Error GoTo 0

fType(0) = 0: fData(0) = "INSERT": fType(1) = 2: fData(1) = BlockToFind
BlockSS.Select acSelectionSetAll, , , fType, fData

For secili = 0 To BlockSS.Count - 1
BlockSS.Item(secili).Explode
Next secili

BlockSS.Delete
End Sub
Sub BlockPatlat()
Dim objEnt As AcadObject

On Error Resume Next

Do
Do While Err = 0

ThisDrawing.Utility.GetEntity objEnt, emptyPt, "Patlatmak istediğiniz Blocklara ait bir obje seçiniz: "

If Err <> 0 Then
' esc, space veya enter tıklanırsa sonlandır
If CInt(ThisDrawing.GetVariable("ERRNO")) = 52 Then
ThisDrawing.SendCommand Chr(3)
Err.Clear
Exit Sub
Else
ThisDrawing.Utility.Prompt "Obje Seçmediniz !" & vbCrLf
Err.Clear
Exit Do
End If
End If

If objEnt.ObjectName = "AcDbBlockReference" Then
BlocksExplode (objEnt.Name)
Else
ThisDrawing.Utility.Prompt "Lütfen BLOCK Seçiniz !" & vbCrLf
Err.Clear
Exit Do
End If

Loop
Loop

End Sub

Ekler:
Dosya: BlocksExplode.zip
Dosya içeriği: BlocksExplode.bas

Kolay gelsin.