i want to do indexing in my designs but sometime design has 10 pages sometime 100 and sometime its 500
i will wrote indexing according to the pages for example i have 10 pages book and now i have wrote all the index example are below
abc
def
ghi
jkl
mno
pqr
stu
wvx
yz1
234
now i will create a box of 15mm X10mm height box with a cut mark of 2 mm in bottom right of the box and
add all text to box according to the box for example 1st index in top 1st box, 2nd index in 2nd box etc.
now i group all box with index.
now i have 10 box with index grouped.
now i move them to the bottom right side according to the series
last step i paste 1 by 1 on different pages. 1st index on 1st page, 2nd on 2nd page and soo on
just like this i want macro
paraggoyal said:eskimo is there any way just like this we can move our first top text to first box, second text to to second box etc. text would be in 1 paragraph. ?
I don't know if I understand what you are asking for here.
When I do this, each box + text is a group:
just like this
paraggoyal said: just like this
Sub text_paras_to_rectangles()Dim sr1 As ShapeRangeDim sr2 As ShapeRangeDim para_count As LongDim counter_1 As LongDim s2 As ShapeDim 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 Next counter_1 ActiveSelection.Shapes.All.RemoveFromSelectionExitSub: Optimization = False EventsEnabled = True Application.Refresh ActiveDocument.EndCommandGroup Exit SubErrHandler: MsgBox "Error occurred: " & Err.Description Resume ExitSubEnd Sub
Select the paragraph text shape and all of the rectangles, then run the macro.
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 ShapeRangeDim sr2 As ShapeRangeDim sr3 As New ShapeRangeDim para_count As LongDim counter_1 As LongDim s2 As ShapeDim 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.RemoveFromSelectionExitSub: Optimization = False EventsEnabled = True Application.Refresh ActiveDocument.EndCommandGroup Exit SubErrHandler: MsgBox "Error occurred: " & Err.Description Resume ExitSubEnd 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 corelplease 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.
thats fine if it is not working in group but why it shows me error, corel comes slow, transformation position shows wrong distance etc ?
i use a box like this below one
paraggoyal said: thats fine if it is not working in group but why it shows me error, corel comes slow, transformation position shows wrong distance etc ? i use a box like this below one
I think the problem is that my macro aligns and then groups text+rectangle, but is not expecting the rectangle to already be part of a group. That's what you are trying to have it work with now.Here is a modified version of the macro that does not look for rectangles. Instead if uses all shapes (including groups) that are not text shapes.If the shape that it is using is a group, then the text will be aligned to the entire group. If each of your cut marks is grouped with a rectangle, and on the edge of that rectangle as in your example, then that would not be a problem.Sub text_paras_to_shapes()Dim sr1_index As LongDim sr1 As ShapeRangeDim sr2 As New ShapeRangeDim sr3 As New ShapeRangeDim para_count As LongDim counter_1 As LongDim s2 As ShapeDim tr As TextRange Optimization = True ActiveDocument.BeginCommandGroup "text paras to shapes" EventsEnabled = False On Error GoTo ErrHandler Set sr1 = ActiveSelectionRange If sr1.Count = 0 Then MsgBox "Nothing is selected." GoTo ExitSub End If sr1_index = 1 Do If sr1(sr1_index).Type = cdrTextShape Then sr2.Add sr1(sr1_index) sr1.Remove (sr1_index) End If sr1_index = sr1_index + 1 Loop Until sr1_index > sr1.Count 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.RemoveFromSelectionExitSub: Optimization = False EventsEnabled = True Application.Refresh ActiveDocument.EndCommandGroup Exit SubErrHandler: MsgBox "Error occurred: " & Err.Description Resume ExitSubEnd SubBefore running macro:After running macro: