Can a macro determine if two letters in an artistic text string overlap?

Ric Harrison
over 1 year ago

Is it possible for a macro to figure out if two adjacent letters in a text string overlap (intersect) without converting the letters to curved objects? My hope is to come up with a macro that can loop through the words and letters in a text string, incrementally decrease the kerning between two adjacent letters until they overlap (visibly touching each other), and then increase the kerning until they have a certain spacing between them?

Parents
  • over 1 year ago

    This will check if text or shapes overlap and return a "CAUTION". Don't know about having it automatically adjust kerning to fix though.

    Sub DetectIntersects()
    Dim sr As ShapeRange, srText As ShapeRange
    Dim s1 As Shape, s2 As Shape, s3 As Shape, s4 As Shape
    Dim bDuplicated As Boolean, bFound As Boolean

    bFound = False

    Set sr = ActiveSelectionRange.Shapes.FindShapes() 'Find all the shapes inside groups, this will also return the group as a shape
    sr.RemoveRange sr.FindAnyOfType(cdrGroupShape, cdrGuidelineShape, cdrBitmapShape) 'Remove any groups, guidelines or Bitmaps

    For Each s1 In sr.Shapes
    bDuplicated = False
    If bFound Then Exit For

    ' If the shape is text, make a duplicate and convert the duplicate to curves
    If s1.Type = cdrTextShape Then
    Set s1 = s1.Duplicate
    s1.ConvertToCurves
    bDuplicated = True
    End If

    'Loop each shape to see if it intersects with the current shape
    For Each s2 In sr.Shapes
    If Not s1 Is s2 And s2.Type <> cdrTextShape Then
    If s1.DisplayCurve.IntersectsWith(s2.DisplayCurve) Then
    bFound = True
    Exit For
    End If
    End If
    Next s2

    'If the shape was text we need to break it apart and see if any letters intersect
    If bDuplicated Then
    Set srText = s1.BreakApartEx
    For Each s3 In srText.Shapes
    If bFound Then Exit For

    For Each s4 In srText.Shapes
    If Not s3 Is s4 Then
    If s3.DisplayCurve.IntersectsWith(s4.DisplayCurve) Then
    bFound = True
    Exit For
    End If
    End If
    Next s4
    Next s3

    srText.Delete
    End If
    Next s1
    If bFound Then MsgBox "CAUTION, Something Intersects!!!", vbCritical
    If Not bFound Then MsgBox "File is good, Nothing Interects."
    End Sub

Reply Children

© Corel Corporation. All rights reserved. The content herein is in the form of a personal web log ("Blog") or forum posting. As such, the views expressed in this site are those of the participants and do not necessarily reflect the views of Corel Corporation, or its affiliates and their respective officers, directors, employees and agents. Terms of Use / Privacy​ ​/ ​Cookies / Terms and Conditions / User Guidelines.