View Single Post
  #8  
Old 20-02-2015, 11:45
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,787
Blog Entries: 11
Send a message via ICQ to shelbym Send a message via AIM to shelbym Send a message via MSN to shelbym Send a message via Yahoo to shelbym
Default Characters to Curves

Shark makes a very good point. One problem when using the break apart with text is that it only returns the first line, so you have to be a little creative to find the other lines of text. Here is another version that builds on Shark's approach.

This version will actually work paragraph text, multiple lines or artistic text, etc.
Code:
Sub BetterIndividualCharacters()
    Dim s As Shape
    Dim srSelection As ShapeRange
    Dim srStateBefore As ShapeRange, srStateAfter As ShapeRange
    
    Set srSelection = ActiveSelectionRange
    Set srStateBefore = ActivePage.FindShapes(Type:=cdrTextShape)
    
    Optimization = True
    ActiveDocument.BeginCommandGroup "Characters to Curves"
    EventsEnabled = False
    ActiveDocument.PreserveSelection = False
    ActiveDocument.SaveSettings
    
        'Breaks Text into Line
        For Each s In srSelection
            If s.Type = cdrTextShape Then
                If s.Text.Type = cdrParagraphText Then s.Text.ConvertToArtistic
                If s.Text.Story.Lines.Count > 1 Then s.BreakApart
            End If
        Next s
    
        Set srStateAfter = ActivePage.FindShapes(Type:=cdrTextShape)
        srStateAfter.RemoveRange srStateBefore
        srSelection.AddRange srStateAfter
        
        Set srStateBefore = ActivePage.FindShapes(Type:=cdrTextShape)
        
        'Breaks Text into Words
        For Each s In srSelection
            If s.Type = cdrTextShape Then
                If s.Text.Story.Words.Count > 1 Then s.BreakApart
            End If
        Next s
    
        Set srStateAfter = ActivePage.FindShapes(Type:=cdrTextShape)
        srStateAfter.RemoveRange srStateBefore
        srSelection.AddRange srStateAfter
        
        Set srStateBefore = ActivePage.FindShapes(Type:=cdrTextShape)
        
        'Breaks Text into Characters
        For Each s In srSelection
            If s.Type = cdrTextShape Then
                s.BreakApart
            End If
        Next s
    
        Set srStateAfter = ActivePage.FindShapes(Type:=cdrTextShape)
        srStateAfter.RemoveRange srStateBefore
        srSelection.AddRange srStateAfter
        
        'Converts Character to Curves
        For Each s In srSelection
            If s.Type = cdrTextShape Then
                s.ConvertToCurves
            End If
        Next s
        
        srSelection.CreateSelection

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

ErrHandler:
    MsgBox "Error occured: " & Err.Description
    Resume ExitSub
Hope it works a little better for everyone,

-Shelby
Reply With Quote