View Single Post
  #2  
Old 26-05-2003, 07:34
dcsquare
Guest
 
Posts: n/a
Default

I've solved the problem. Here is the code (not the most elegant method, but... it works):

Code:
Sub fit_path()
Dim sh As Shape
Dim x, y
Dim i, max, fsize
max=2
ActiveDocument.Unit = cdrMillimeter
ActiveDocument.ReferencePoint = cdrCenter
For i = ActiveLayer.Shapes.Count To 1 Step -1
    Set sh = ActiveLayer.Shapes(i)
    If sh.Type = cdrCurveShape Then
        If ActiveLayer.Shapes(i - 1).Type = cdrTextShape Then
            ActiveLayer.Shapes(i - 1).Text.FitToPath sh
            x = Abs(ActiveLayer.Shapes(i).PositionX - ActiveLayer.Shapes(i - 1).PositionX)
            y = Abs(ActiveLayer.Shapes(i).PositionY - ActiveLayer.Shapes(i - 1).PositionY)
            While x > max Or y > max
                fsize = ActiveLayer.Shapes(i - 1).Text.Story.Size
                With ActiveLayer.Shapes(i - 1).Text.SpaceProperties
                    .CharacterSpacing = .CharacterSpacing + fsize
                    .WordSpacing = .WordSpacing + fsize
                End With
                If x > Abs(ActiveLayer.Shapes(i).PositionX - ActiveLayer.Shapes(i - 1).PositionX) Then
                    x = Abs(ActiveLayer.Shapes(i).PositionX - ActiveLayer.Shapes(i - 1).PositionX)
                Else: x = 1
                End If
                If y > Abs(ActiveLayer.Shapes(i).PositionY - ActiveLayer.Shapes(i - 1).PositionY) Then
                    y = Abs(ActiveLayer.Shapes(i).PositionY - ActiveLayer.Shapes(i - 1).PositionY)
                Else: y = 1
                End If
            Wend
        Else
            Set sh = ActiveLayer.Shapes(i - 1).Weld(sh)
            sh.OrderBackOf ActiveLayer.Shapes(i - 1)
        End If
    End If
Next i
End Sub
It's a little more complicated because the control curves could be broken, so I needed to weld them.
For the code to work, you need to place the text to be fitted immediately above the control curve in object manager. It works for any number of text and curves that are on the same layer.
Reply With Quote