Attribute VB_Name = "modChangeGroupsToBlocks"
'*************************************************************
'**   autor: Harry    (c)2010                               **
'**   zmariusz@poczta.fm                                    **
'**   odwiedŸ www.vbamania.pl                               **
'*************************************************************
'** Makro zamienia wszystkie grupy, powstałe przy eksporcie **
'** w programu Inventor, na bloki                           **
'*************************************************************

Option Explicit

Sub ChangeGroupsToBlocks()
Dim oDoc As ThisDrawing
Set oDoc = ThisDrawing
Dim msg As String
Dim groupObj As AcadGroups
Set groupObj = oDoc.Groups
Dim elg As AcadGroup
Dim gBlock As AcadBlock

If groupObj.Count = 0 Then MsgBox "Aktywny rysunke nie posiada grup!", vbCritical: GoTo mEnd
msg = "Zamieniono " & groupObj.Count & " grup."

Dim iPnt(0 To 2) As Double: iPnt(0) = 0#: iPnt(1) = 0#: iPnt(2) = 0#

Dim el
For Each elg In groupObj
    If Not elg.Count = 0 Then
        Set gBlock = oDoc.Blocks.Add(iPnt, elg.Name)
        oDoc.CopyObjects ssArray(elg), gBlock
        oDoc.ModelSpace.InsertBlock iPnt, elg.Name, 1, 1, 1, 0
        Set gBlock = Nothing
    End If
Next elg

UsunGrupy groupObj

MsgBox msg
mEnd:
Set groupObj = Nothing
Set oDoc = Nothing
End Sub

Function ssArray(elg As AcadGroup) As Variant

Dim retVal() As AcadEntity, i As Long
ReDim retVal(0 To elg.Count - 1)
     
For i = 0 To elg.Count - 1
    Set retVal(i) = elg.Item(i)
Next i

ssArray = retVal

End Function

Sub UsunGrupy(oGr As AcadGroups)
'usun grupy
Dim elg As AcadGroup
Dim el As Variant
For Each elg In oGr
    For Each el In elg
        el.Delete
    Next el
    elg.Delete
Next elg

End Sub