OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > CorelDRAW/Corel DESIGNER VBA

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 16-02-2015, 05:15
dungbtl's Avatar
dungbtl dungbtl is offline
Senior Member
 
Join Date: Apr 2004
Posts: 148
Default Text Break Apart Re-Combine Individually

Is this possible to select Text...

Convert to Curves
Ungroup if necessary (some long text goes into group mode)
Combine/Breakapart

and then cycle thru the selection and Combine the letters to be completed as a whole. A,B,D, yada yada yada.

See image



Lookin for a faster way.
Attached Images
 
Reply With Quote
  #2  
Old 16-02-2015, 18:16
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,782
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 Combine

You could do something like this:
Code:
Sub IndividualCharacters()
    Dim sr As ShapeRange
    Dim srFound As ShapeRange
    Dim x As Double, y As Double, w As Double, h As Double
    
    ActiveSelectionRange.ConvertToCurves
    Set sr = ActiveSelectionRange.BreakApartEx
    
    Do
        sr.Shapes.First.GetBoundingBox x, y, w, h
        Set srFound = ActivePage.SelectShapesFromRectangle(x, y, x + w, y + h, True).Shapes.FindShapes()
        sr.RemoveRange srFound
        If srFound.Count > 1 Then srFound.Combine
    Loop Until sr.Count = 0
End Sub
Hope that gets you started,

-Shelby

Last edited by shelbym; 16-02-2015 at 18:19.
Reply With Quote
  #3  
Old 18-02-2015, 08:27
ddonnahoe's Avatar
ddonnahoe ddonnahoe is offline
Senior Member
 
Join Date: Jan 2004
Location: Louisville, KY
Posts: 552
Send a message via ICQ to ddonnahoe Send a message via AIM to ddonnahoe Send a message via MSN to ddonnahoe Send a message via Yahoo to ddonnahoe
Default

Shelby, that is awesome. Quite a few lines less than what I was thinking; however, it does leave a small issue. If the kerning of your characters has the bounding box overlapping each other, then those characters get combined. (i.e. LY). How would we fix this?

I was originally thinking along the lines of using, IsShapeInside to accomplish this.
__________________
Sean
Waiting for a ride in the T.A.R.D.I.S.
Reply With Quote
  #4  
Old 18-02-2015, 18:13
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,782
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 Overlap

Sean,

Actually, you should be able to fix that by just turning off Touch:
Code:
Set srFound = ActivePage.SelectShapesFromRectangle(x, y, x + w, y + h, True).Shapes.FindShapes()
to
Code:
Set srFound = ActivePage.SelectShapesFromRectangle(x, y, x + w, y + h, False).Shapes.FindShapes()
That way only shapes that are 100% inside the Rectangle get selected. Your LY should work fine in this case.

-Shelby
Reply With Quote
  #5  
Old 19-02-2015, 03:14
shark shark is offline
Senior Member
 
Join Date: Aug 2010
Location: Russia, Belgorod
Posts: 146
Default

interesting code.
I once solved this problem in a different way: broke all text into the letters, adding characters to shaperange, and converted it to curves
Reply With Quote
  #6  
Old 19-02-2015, 08:38
dungbtl's Avatar
dungbtl dungbtl is offline
Senior Member
 
Join Date: Apr 2004
Posts: 148
Default

Lol... man... shelby & sean are never tired doing codes as such.

Thanx a batch! You too Shark.

This will work quite well.
Reply With Quote
  #7  
Old 19-02-2015, 11:20
shark shark is offline
Senior Member
 
Join Date: Aug 2010
Location: Russia, Belgorod
Posts: 146
Default

Some languages, for example my native, have a letters that consists of several elements: points, hooks, sticks (? (like "E" with points over), ? (mirrored "N" with hook), ? (like "b" and "I")). And the above code breaks such characters into separate components. Therefore, in my opinion, it is better to curve each letter individually
Reply With Quote
  #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,782
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
  #9  
Old 21-02-2015, 12:26
shark shark is offline
Senior Member
 
Join Date: Aug 2010
Location: Russia, Belgorod
Posts: 146
Default My macros

Hi
Here is my code. slightly shorter
Code:
Private Sub Break(sBreak As Shape, srStore As ShapeRange)
Dim sPrev As Shape, s As Shape, sr As ShapeRange
    Set sPrev = sBreak.Previous
    Set s = sBreak
    Set sr = s.BreakApartEx
    Do While s.StaticID <> sPrev.StaticID
        If s.Text.Story.Words.Count > 1 Then
            Break s, sr
        Else
            If s.Text.Story.Characters.Count > 2 Then 'how i realized - single character is represented by two textshapes: letter itself and empty shape, don't know why 
                sr.AddRange s.BreakApartEx
            Else
                sr.Add s
            End If
        End If
        Set s = s.Previous
    Loop
    srStore.AddRange sr
End Sub

Sub Break_Text()
Dim sr As ShapeRange, tsr As ShapeRange, sPrev As Shape, s As Shape
    Set s = ActiveShape
    If s Is Nothing Then MsgBox "nothing selected!", vbCritical: Exit Sub
    If s.Type <> cdrTextShape Then MsgBox "Is not text shape!", vbCritical: Exit Sub
    If s.Text.Type <> cdrArtisticText Then s.Text.ConvertToArtistic
    
    Set sr = New ShapeRange
    Break s, sr
    sr.ConvertToCurves
End Sub
Reply With Quote
  #10  
Old 28-02-2015, 05:42
dungbtl's Avatar
dungbtl dungbtl is offline
Senior Member
 
Join Date: Apr 2004
Posts: 148
Thumbs up

Shark,
You're 100% correct on that. But it's not just for text. It works for regular
objects that have holes inside also. I like it, made my work even faster for my needs.



Quote:
Originally Posted by shark View Post
Some languages, for example my native, have a letters that consists of several elements: points, hooks, sticks (? (like "E" with points over), ? (mirrored "N" with hook), ? (like "b" and "I")). And the above code breaks such characters into separate components. Therefore, in my opinion, it is better to curve each letter individually
Reply With Quote
Reply


Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)
 
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is Off

Forum Jump

Similar Threads
Thread Thread Starter Forum Replies Last Post
Macro for individually scaling objects ajesion Macros/Add-ons 5 12-12-2010 08:28
I Need to combine the two Macro’s below into One Button: GWB Daniels Macros/Add-ons 1 28-07-2010 23:53
Combine Textrows... WernerHo Macros/Add-ons 6 15-12-2009 10:44
Exporting all items individually from 1 page fungel General 1 05-07-2009 11:46
Corel 9 VBA Weld and Combine korner CorelDRAW/Corel DESIGNER VBA 2 07-10-2004 10:48


All times are GMT -5. The time now is 02:03.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2021, Jelsoft Enterprises Ltd.
Copyright © 2011, Oberonplace.com