need help but situation has multiple challenges

Thinking about how you might be using this, this version also groups each piece of text with its rectangle.

Sub text_paras_to_rectangles()
Dim sr1 As ShapeRange
Dim sr2 As ShapeRange
Dim sr3 As New ShapeRange
Dim para_count As Long
Dim counter_1 As Long
Dim s2 As Shape
Dim tr As TextRange

    Optimization = True
    ActiveDocument.BeginCommandGroup "text paras to rectangles"
    EventsEnabled = False
    On Error GoTo ErrHandler
    
    Set sr1 = ActiveSelection.Shapes.FindShapes(, cdrRectangleShape)
    If sr1.Count = 0 Then
        MsgBox "No rectangles were found in the selection."
    GoTo ExitSub
    End If
    
    Set sr2 = ActiveSelection.Shapes.FindShapes(, cdrTextShape)
    If sr2.Count = 0 Then
        MsgBox "No text shape was found in the selection."
        GoTo ExitSub
    Else
        If sr2.Count > 1 Then
            MsgBox "More than one text shape was found in the selection."
            GoTo ExitSub
        End If
    End If
    
    para_count = sr2(1).Text.Story.Paragraphs.Count
    If para_count > sr1.Count Then
        MsgBox "The number of paragraphs in the text shape (" & para_count & ") is more than the number of rectangles (" & sr1.Count & ") in the selection."
        GoTo ExitSub
    End If
        
    sr1.Sort "@shape1.top>@shape2.top"
    
    For counter_1 = 1 To para_count
        Set tr = sr2(1).Text.Story.Paragraphs(counter_1)
        Set s2 = ActiveDocument.ActiveLayer.CreateArtisticText(0, 0, tr.Text, , , tr.Font, tr.Size, tr.Bold, tr.Italic, tr.Underline)
        s2.Fill = tr.Fill
        s2.CenterX = sr1(counter_1).CenterX
        s2.CenterY = sr1(counter_1).CenterY
        sr3.RemoveAll
        sr3.Add s2
        sr3.Add sr1(counter_1)
        sr3.Group
    Next counter_1
    
    ActiveSelection.Shapes.All.RemoveFromSelection

ExitSub:
    Optimization = False
    EventsEnabled = True
    Application.Refresh
    ActiveDocument.EndCommandGroup
    Exit Sub

ErrHandler:
    MsgBox "Error occurred: " & Err.Description
    Resume ExitSub
End Sub

paraggoyal said:

eskimo this code is giving me some issues
1. when i use this code it show an error of "encountered an improper argument".
2. cant able to undo anything after this code when i try to undo it show always this code till i restart
3. when i try this code on a rectangle with a cutting mark on bottom of the rectangle and make both group then it automatically ungroup both cutting mark and rectangle after applying this code.
4. Transformation position tool also not work it shows always wrong distance till i restart my corel
please help

I wrote the code to work with rectangles - not rectangles that belong to groups.

Would you please post a picture (e.g., from the Windows Snipping tool) showing what one of your groups (rectangle + cutting mark) looks like? Depending on the type of cutting mark you are using, there might be a very simple way to modify the code to get it working for groups.

Chris.1 said:

eskimo sir.
can we make these changes in this macro code ?

If you want custom macro capabilities, then you might consider learning about writing VBA and how to use it in CorelDRAW. That would allow you to write exactly what you want, when you want.

As an alternative, you could look for people who write custom macros professionally, as a business. If you ask on the Developer Forum here on the Community web site, you might be able to find people who do that.

i thought that was your code and you can easily make changes in these both codes. if you can will you please do that for me ?
i am new here don't know much about vba