AutoPowerClipMultiple_khmer_Coreldraw_VBA_Free

Option Explicit

Sub AutoPowerClip100()

    On Error GoTo ErrHandler

    Dim sr As ShapeRange
    Dim imgs() As Shape
    Dim frames() As Shape

    Dim i As Long
    Dim imgCount As Long
    Dim frameCount As Long

    Optimization = True
    ActiveDocument.BeginCommandGroup "Auto PowerClip"

    Set sr = ActiveSelectionRange

    If sr.Count < 2 Then
        MsgBox "Please select Images first, then Frames.", vbExclamation
        GoTo ExitSub
    End If

    '-----------------------------------
    ' Detect Frames
    ' Rectangle / Curve / Ellipse
    '-----------------------------------
    For i = 1 To sr.Count

        Select Case sr(i).Type

            Case cdrRectangleShape, cdrEllipseShape, cdrCurveShape
                frameCount = frameCount + 1
                ReDim Preserve frames(1 To frameCount)
                Set frames(frameCount) = sr(i)

            Case Else
                imgCount = imgCount + 1
                ReDim Preserve imgs(1 To imgCount)
                Set imgs(imgCount) = sr(i)

        End Select

    Next i

    If imgCount = 0 Then
        MsgBox "No Images found."
        GoTo ExitSub
    End If

    If frameCount = 0 Then
        MsgBox "No Frames found."
        GoTo ExitSub
    End If

    If imgCount <> frameCount Then

        MsgBox "Images = " & imgCount & vbCrLf & _
               "Frames = " & frameCount & vbCrLf & _
               "Numbers must be equal."

        GoTo ExitSub

    End If

    '-----------------------------------
    ' PowerClip
    '-----------------------------------
    For i = 1 To imgCount

        imgs(i).AddToPowerClip frames(i)

    Next i

ExitSub:

    ActiveDocument.EndCommandGroup
    Optimization = False
    ActiveWindow.Refresh

    Exit Sub

ErrHandler:

    Optimization = False
    ActiveWindow.Refresh
    On Error Resume Next
    ActiveDocument.EndCommandGroup

    MsgBox Err.Number & vbCrLf & Err.Description

End Sub