Code:
Option ExplicitSub ExplodeAllBlocks()
Dim swApp As Object
Dim DrawingDoc As Object
Dim i, j, k, l As Long
Dim BlattformatName, BlockName As String
Dim SketchMgr As SldWorks.SketchManager
Dim swBlockDef As SldWorks.SketchBlockDefinition
Dim vBlockDef As Variant
Dim vBlockInst As Variant
Dim AnzahlBl, Blockanzahl As Long
Dim SheetName As String
Dim Sheet As Object
Dim retval, Features As Variant
Dim Feature, swFeat As SldWorks.Feature
Dim boolstatus As Boolean
Set swApp = Application.SldWorks
Set DrawingDoc = swApp.ActiveDoc
Set Feature = DrawingDoc.FirstFeature
AnzahlBl = DrawingDoc.GetSheetCount
Set Sheet = DrawingDoc.GetCurrentSheet
SheetName = Sheet.GetName
'Auf erstes Blatt springen
For l = 1 To AnzahlBl - 1
DrawingDoc.SheetPrevious
Set Sheet = DrawingDoc.GetCurrentSheet
If (SheetName = Sheet.GetName) Then
Exit For
End If
SheetName = Sheet.GetName
Next l
'Alle Blöcke auflösen, die direkt auf dem Blatt liegen
For l = 1 To AnzahlBl
Set Sheet = DrawingDoc.GetCurrentSheet
'Nebenbei Blätter umbenennen
SheetName = "Blatt" & l
Sheet.SetName (SheetName)
DrawingDoc.EditSketch
DrawingDoc.ClearSelection2 True
Set SketchMgr = DrawingDoc.SketchManager
vBlockDef = SketchMgr.GetSketchBlockDefinitions
' Exit if no blocks
If IsEmpty(vBlockDef) Then
Exit Sub
End If
If Not IsEmpty(vBlockDef) Then
For i = 0 To UBound(vBlockDef)
Set swBlockDef = vBlockDef(i)
vBlockInst = swBlockDef.GetInstances
If Not IsEmpty(vBlockInst) Then
For j = 0 To UBound(vBlockInst)
SketchMgr.ExplodeSketchBlockInstance vBlockInst(j)
Next j
End If
Next i
End If
If AnzahlBl > l Then
DrawingDoc.SheetNext
End If
Next l
DrawingDoc.ActivateSheet ("Blatt1")
'Alle Blöcke auflösen, die im Blattformat liegen
Do While Not Feature Is Nothing
If Feature.GetTypeName() = "DrSheet" Then
BlattformatName = Feature.Name
boolstatus = DrawingDoc.Extension.SelectByID2(BlattformatName, "SHEET", 0, 0, 0, False, 0, Nothing, 0)
DrawingDoc.EditTemplate
DrawingDoc.EditSketch
DrawingDoc.ClearSelection2 True
Set SketchMgr = DrawingDoc.SketchManager
vBlockDef = SketchMgr.GetSketchBlockDefinitions
' Exit if no blocks
If IsEmpty(vBlockDef) Then
Exit Sub
End If
If Not IsEmpty(vBlockDef) Then
For i = 0 To UBound(vBlockDef)
Set swBlockDef = vBlockDef(i)
vBlockInst = swBlockDef.GetInstances
If Not IsEmpty(vBlockInst) Then
For j = 0 To UBound(vBlockInst)
SketchMgr.ExplodeSketchBlockInstance vBlockInst(j)
Next j
End If
Next i
End If
DrawingDoc.ClearSelection2 True
DrawingDoc.EditSheet
DrawingDoc.SheetNext
End If
Set Feature = Feature.GetNextFeature
Loop
'Alle Blöcke löschen
Set swFeat = swBlockDef.GetFeature
Do While Not swFeat Is Nothing
If swFeat.GetTypeName() = "SketchBlockDef" Then
retval = swFeat.Select2(False, -1)
retval = DrawingDoc.DeleteSelection(False)
End If
DrawingDoc.ClearSelection2 True
Set swFeat = swFeat.GetNextFeature
Loop
End Sub
Foren auf CAD.de (alle Foren)
| 
!
) 
)
Das kann sowieso da weg. Ich selektiere ja in dem Sinne nichts. 
