Text near text

Hi,

I have a lot of single line texts with single line text below (within 1' lets say). Is it possible to replace all text with a concatenation of the two? The contents of the text below tell me that it is a 2nd line, let's say it begins with '2'.

Thanks!

Parents

No Data

Reply

Shelby Moore over 2 years ago

Here is my attempt at this.

This is what the Text looked like before:

And here is what it looks like after the Macro runs:

There are several areas this could be improved, but wanted to keep it simple to get you started. Here is the code:

Sub FindTextConcatenation()
    Dim s As Shape
    Dim srText As ShapeRange, srFound As ShapeRange, srDelete As New ShapeRange
    
    'Find all the Text on the Active Page
    Set srText = ActivePage.Shapes.FindShapes(Type:=cdrTextShape)
    'Sort the Text ShapeRange Top to Bottom on the Page
    srText.Sort "@shape1.Top > @shape2.Top"
    
    'Loop through all the Text Shapes
    For Each s In srText.Shapes
        'If the shape has been added to the Delete ShapeRange we want to just skip it
        If srDelete.IndexOf(s) = 0 Then
            'Using CQL we find the line of text that is withing 1" of the other
            Set srFound = srText.Shapes.FindShapes(Query:="@com.StaticID <> " & s.StaticID & " and @Bottom < {" & s.BottomY & "in} and @Bottom > {" & s.BottomY - 1 & "in} and @CenterX > {" & s.CenterX - 1 & " in} and @CenterX < {" & s.CenterX + 1 & " in}")
            'Concatenate the two lines of Text
            s.Text.Story.Text = s.Text.Story.Text & " " & srFound.FirstShape.Text.Story.Text
            'Add the found text to the delete ShapeRange
            srDelete.Add srFound.FirstShape
        End If
    Next s
    
    srDelete.Delete
End Sub

Happy Coding!

-Shelby

Children

Jr. over 2 years ago in reply to Shelby Moore

Thanks! I can learn a lot from this.
Cancel
Up 0 Down

Reply

Cancel