Sub UnGroupAndAssignLayers()
Dim sh As Shape, ssh As Shape, ln$, L As Layer
Dim lErr$, errCnt&, i&, j&, cnt&, cntOrig&, step&
Dim sr As New ShapeRange, ssr As ShapeRange, srU As New ShapeRange
Set sr = ActiveSelectionRange
cntOrig = sr.Count: If cntOrig = 0 Then Beep: Exit Sub
Set stat = Application.Status
stat.BeginProgress CanAbort:=True
Optimization = True: EventsEnabled = False
ActiveDocument.PreserveSelection = False
ActiveDocument.BeginCommandGroup "Ungroup and assign layers"
On Error GoTo ErrLayer
For Each sh In sr
i = i + 1
If sh.Type = cdrGroupShape Then
Set ssr = sh.UngroupEx: srU.AddRange ssr
j = 0: cnt = ssr.Count: step = cnt \ 100: If step = 0 Then step = 1
stat.SetProgressMessage "Smart ungroup " + _
IIf(cntOrig = 1, "", "shape # " + CStr(i) + " / " + CStr(cntOrig))
For Each ssh In ssr
j = j + 1
If j Mod step = 1 Then stat.Progress = j / cnt * 100: _
If stat.Aborted Then Exit For
ln = ssh.Properties("Layer", 0)
If ln <> "" Then
If ln = "Desktop" _
Then Set L = ActiveDocument.MasterPage.Layers("Desktop") _
Else Set L = ActivePage.Layers(ln)
If Not L Is Nothing Then ssh.Layer = L
End If
SkipErr: Next
Else ' just a shape, add it to final selection
srU.Add sh
End If
If stat.Aborted Then Exit For
Next
stat.EndProgress
ActiveDocument.EndCommandGroup
ActiveDocument.PreserveSelection = True
EventsEnabled = True: Optimization = False
srU.CreateSelection
Application.Refresh
If Not CorelDRAW.CorelScript Is Nothing Then _
CorelDRAW.CorelScript.RedrawScreen
If errCnt > 0 Then _
MsgBox "Layers not found: " + lErr + vbCrLf + _
CStr(errCnt) + " shapes referenced missing layers" + vbCrLf + vbCrLf + _
"Ungroupped to " + ActiveLayer.Name
Exit Sub
ErrLayer:
err.Clear: lErr = lErr + ln + ", ": errCnt = errCnt + 1: Resume SkipErr
End Sub