OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Corel User Forums > CorelDRAW > Macros/Add-ons

Reply
 
Thread Tools Search this Thread Display Modes
  #21  
Old 04-07-2006, 13:13
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,769
Blog Entries: 10
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 A Work in Progress

Here is some updated code that does some of what you like. I have changed a couple things to show you there is more then one way to do this. Some of these changes include:

1. Adding Constants, this makes that changes a little easier
2. I now get the mark locations from the getposition, makes the math a little easier to understand when creating the marks.

Also added:

1. Alignment Marks can now be assigned a color
2. Alignment Marks can now be grouped to the original selection

It does have one bug that I know of, if your original selection is already a group is creates a group of 1 object (Still working of this).

Now we just need to add some UI to this so you can make changes without accessing the code, coming soon....

Code:
Sub AlignmentMarks()

Const MarkLength As Double = 0.5 'Change this numer to adjust the Alignment Mark Length
Const Offset As Double = 0.125 'Chage this number to adjust the gap between the design and Alignment Mark
Const OutlineWidth As Double = 0.028 'Change this number to adjust the Outline Width (In Inches)
Const Cyan As Long = 0 'Adjust These Numbers to Change Color (Currently Set to Red)
Const Magenta As Long = 100
Const Yellow As Long = 100
Const Black As Long = 0
Const Group As Boolean = True 'Set this if you want the Alignmentment Marks Group with the Objects you Selected

Dim sSelection As Shape
Dim srAlignmentMarks As New ShapeRange
Dim sAlignmentMarksGroup As Shape, grp As Shape
Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
Dim x3 As Double, y3 As Double, x4 As Double, y4 As Double

'Checks to see if you have something selected
If ActiveSelectionRange.Count = 0 Then
    MsgBox "Please Select The Object(s) To Create Alignment Marks", , "Alignment Marks"
    Exit Sub
Else
    Optimization = True
    ActiveDocument.BeginCommandGroup "Alignment Marks"
    On Error GoTo ErrHandler
    
    'If group option is True then groups your selection
    If Group = True Then
        'Checks to see if CurrentSelection is already a group
        If ActiveDocument.SelectionInfo.IsGroup = False Then
            Set sSelection = ActiveSelection.Group
        Else
            Set sSelection = ActiveSelection
        End If
    Else
        Set sSelection = ActiveSelection
    End If
End If

'Get the position for the Alignment Marks
ActiveDocument.ReferencePoint = cdrBottomMiddle
sSelection.GetPosition x1, y1

ActiveDocument.ReferencePoint = cdrTopMiddle
sSelection.GetPosition x2, y2

ActiveDocument.ReferencePoint = cdrMiddleLeft
sSelection.GetPosition x3, y3

ActiveDocument.ReferencePoint = cdrMiddleRight
sSelection.GetPosition x4, y4

'Create AlignmentMarks and Add to ShapeRange
srAlignmentMarks.add ActiveLayer.CreateLineSegment(x1, y1 - Offset, x1, y1 - Offset - MarkLength)
srAlignmentMarks.add ActiveLayer.CreateLineSegment(x2, y2 + Offset, x2, y2 + Offset + MarkLength)
srAlignmentMarks.add ActiveLayer.CreateLineSegment(x3 - Offset, y3, x3 - Offset - MarkLength, y3)
srAlignmentMarks.add ActiveLayer.CreateLineSegment(x4 + Offset, y4, x4 + Offset + MarkLength, y4)

'Set the Outline Width and Color
srAlignmentMarks.SetOutlineProperties OutlineWidth, , Color:=CreateCMYKColor(Cyan, Magenta, Yellow, Black)

'Groups Original Selection, then groups AlignmentMarks, then groups the two together
If Group = True Then
    Set sAlignmentMarksGroup = srAlignmentMarks.Group
    ActiveDocument.CreateSelection sSelection, sAlignmentMarksGroup
    Set grp = ActiveSelection.Group
End If

ActiveDocument.ClearSelection
    
ExitSub:
    Optimization = False
    ActiveWindow.Refresh
    Application.Refresh 'This was added because I was having problems with the Object Manager Docker Refreshing
    ActiveDocument.EndCommandGroup
    Exit Sub

ErrHandler:
    MsgBox "Error occured: " & Err.Description
    Resume ExitSub

End Sub
Best to you,

Shelby
Reply With Quote
  #22  
Old 04-07-2006, 17:07
gingem
Guest
 
Posts: n/a
Default

Hi Shelby
THANK YOU THANK YOU It works great. I might not be good at programming but if you need any engraving or jewelry just let me know!
Reply With Quote
  #23  
Old 11-07-2006, 09:00
Inkman
Guest
 
Posts: n/a
Default

Thanks everyone for responding to my request, I havent been able to post recently and reply to everyone because I had a bit of an accident with a deer on the highway in a Civic doing 70Mph. Not sure how the deer faired because he/she was in a million peices and unable to tell us how he/she felt. But I can ssay the Civic was toast as well as several of my bones. Basically the deer caused my brakes to fail and one tierod to snap so after destroying the deer the car made a bees line to the nearest most convenient tree.

That said Thanks Mamos your right sign software is over priced for our needs and unneeded because I am proficient with Corel Draw and able to do all I need from there.

Shelby the code is working awesome and I am trying to play with it myself, essentially I am trying to make it somehow select the text break it apart if more than one line only and perform the weed and then reselect all and group. Not going well but is still fun trying to figure it all out.
Reply With Quote
  #24  
Old 17-07-2006, 10:49
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,769
Blog Entries: 10
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 New Version Quick Weed

Quote:
Originally Posted by Inkman
...I am trying to make it somehow select the text break it apart if more than one line only and perform the weed and then reselect all and group. Not going well but is still fun trying to figure it all out.
First let me say sorry to hear about your little run in with the deer. That doesn't sound fun at all. But maybe to brighten your day I have reworked the script for what you are trying to do. Here are some of the new features:

1. Offset and Group are now constants at the top of the code for easy changes. (Next version should have a dialog for changes.)
2. Code now works for CorelDRAW 12 and X3 (12 will not remove lines from centers of letters like "O" or "A", but at least it works)
3. Added a grouping feature: If group = true then the weed border is a single group, the text another group, and these two are then grouped into a single group. (Again helps for editing or quickly deleting the weedborder)
4. Paragraph text is now converted to Artistic text
5. Artistic text with multiple lines are converted to individual lines. (This lets the weed border hit it like of text.)

That is all I remember off the top of my head. If you or others would like to see additional features/changes let me know and I will see what I can do.

If you find any bugs would your please report them directly to me at shelbym@v-cut.com with the subject "Quick Weed Bug".

Hope you get feeling better,

Shelby
Code:
Sub QuickWeed()

Const Offset As Double = 0.5 'Chage this number to adjust the gap between rectangle created and objects
Const Group As Boolean = True 'Set this if you want the Weed Border and Objects to be grouped

Dim s As Shape
Dim sLine As Shape
Dim sTrim As Shape
Dim sBoundry As Shape
Dim srSelection As ShapeRange
Dim srWeedBorder As New ShapeRange
Dim srFinalGroup As New ShapeRange
Dim srStateBefore As ShapeRange
Dim srStateAfter As ShapeRange
Dim x As Double, y As Double, w As Double, h As Double
Dim x1 As Double, y1 As Double

If ActiveSelectionRange.Count = 0 Then
    MsgBox "Please Select the Object(s) to Create a Weed Border", , "Quick Weed"
    Exit Sub
Else
    Set srSelection = ActiveSelectionRange
End If

Optimization = True
ActiveDocument.BeginCommandGroup "Quick Weed"
On Error GoTo ErrHandler

'Get all text objects before operation
Set srStateBefore = ActivePage.FindShapes(Type:=cdrTextShape)

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

'Get all text after operation
Set srStateAfter = ActivePage.FindShapes(Type:=cdrTextShape)
srStateAfter.RemoveRange srStateBefore
srSelection.AddRange srStateAfter

ActiveDocument.ReferencePoint = cdrCenter
srSelection.GetBoundingBox x, y, w, h
Set sRect = ActiveLayer.CreateRectangle2(x - Offset, y - Offset, w + (Offset * 2), h + (Offset * 2))
If Group = True Then srWeedBorder.Add sRect

For Each s In srSelection
    s.GetPosition x1, y1
    Set sLine = ActiveLayer.CreateLineSegment(x - Offset, y1, x + w + Offset, y1)
   
    If VersionMajor = 13 Then
        Set sBoundary = s.CustomCommand("Boundary", "CreateBoundary")
        Set sTrim = sBoundary.Trim(sLine, True, False)
        sBoundary.Delete
    Else
        Set sTrim = s.Trim(sLine, True, False)
    End If
    If Group = True Then srWeedBorder.Add sTrim
Next s

If Group = True Then
    srFinalGroup.Add srSelection.Group
    srFinalGroup.Add srWeedBorder.Group
    srFinalGroup.Group
End If
    
ActiveDocument.ClearSelection
    
ExitSub:
    Optimization = False
    ActiveWindow.Refresh
    Application.Refresh
    ActiveDocument.EndCommandGroup
    Exit Sub

ErrHandler:
    MsgBox "Error occured: " & Err.Description
    Resume ExitSub

End Sub

Last edited by shelbym; 17-07-2006 at 10:55.
Reply With Quote
  #25  
Old 17-07-2006, 10:54
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,769
Blog Entries: 10
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 New Version Alignment Marks

I have fixed the grouping bug with the Alignment Marks code, also this code should work with CorelDRAW 12 and X3. Let me know if anyone would to see new features/changes.

If you find any bugs would your please report them directly to me at shelbym@v-cut.com with the subject "Alignment Marks Bug"
Thanks,

Shelby
Code:
Sub AlignmentMarks()

Const MarkLength As Double = 0.5 'Change this numer to adjust the Alignment Mark Length
Const Offset As Double = 0.125 'Chage this number to adjust the gap between the design and Alignment Mark
Const OutlineWidth As Double = 0.028 'Change this number to adjust the Outline Width (In Inches)
Const Cyan As Long = 0 'Adjust These Numbers to Change Color (Currently Set to Red)
Const Magenta As Long = 100
Const Yellow As Long = 100
Const Black As Long = 0
Const Group As Boolean = True 'Set this if you want the Alignmentment Marks Group with the Objects you Selected

Dim srSelection As ShapeRange
Dim srAlignmentMarks As New ShapeRange
Dim srFinalGroup As New ShapeRange
Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
Dim x3 As Double, y3 As Double, x4 As Double, y4 As Double

'Checks to see if you have something selected
If ActiveSelectionRange.Count = 0 Then
    MsgBox "Please Select The Object(s) To Create Alignment Marks", , "Alignment Marks"
    Exit Sub
Else
    Set srSelection = ActiveSelectionRange
End If

Optimization = True
ActiveDocument.BeginCommandGroup "Alignment Marks"
On Error GoTo ErrHandler

'Get the position for the Alignment Marks
ActiveDocument.ReferencePoint = cdrBottomMiddle
srSelection.GetPosition x1, y1

ActiveDocument.ReferencePoint = cdrTopMiddle
srSelection.GetPosition x2, y2

ActiveDocument.ReferencePoint = cdrMiddleLeft
srSelection.GetPosition x3, y3

ActiveDocument.ReferencePoint = cdrMiddleRight
srSelection.GetPosition x4, y4

'Create AlignmentMarks and Add to ShapeRange
srAlignmentMarks.Add ActiveLayer.CreateLineSegment(x1, y1 - Offset, x1, y1 - Offset - MarkLength)
srAlignmentMarks.Add ActiveLayer.CreateLineSegment(x2, y2 + Offset, x2, y2 + Offset + MarkLength)
srAlignmentMarks.Add ActiveLayer.CreateLineSegment(x3 - Offset, y3, x3 - Offset - MarkLength, y3)
srAlignmentMarks.Add ActiveLayer.CreateLineSegment(x4 + Offset, y4, x4 + Offset + MarkLength, y4)

'Set the Outline Width and Color
srAlignmentMarks.SetOutlineProperties OutlineWidth, , Color:=CreateCMYKColor(Cyan, Magenta, Yellow, Black)

'Groups Original Selection, then groups AlignmentMarks, then groups the two together
If Group = True Then
    srSelection.CreateSelection
    If ActiveDocument.SelectionInfo.IsGroup = False Then
        srFinalGroup.Add srSelection.Group
    Else
        srFinalGroup.AddRange srSelection
    End If
    srFinalGroup.Add srAlignmentMarks.Group
    srFinalGroup.Group
End If

ActiveDocument.ClearSelection
    
ExitSub:
    Optimization = False
    ActiveWindow.Refresh
    Application.Refresh
    ActiveDocument.EndCommandGroup
    Exit Sub

ErrHandler:
    MsgBox "Error occured: " & Err.Description
    Resume ExitSub

End Sub
Reply With Quote
  #26  
Old 23-07-2006, 17:57
gingem
Guest
 
Posts: n/a
Default

Hi Shelby
I have been away and just got a chance to try the new code. It works great and now the grouping also works fine. Thank You!!
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
Looking for VBA or Corel Script for cabinet design HomeDesignerDavid Macros/Add-ons 2 22-03-2011 17:25
NEED HELP ON CORELDRAW SCRIPT. FREE PHOTO CALENDAR IF U CAN! johnlfitz CorelDRAW/Corel DESIGNER VBA 8 06-06-2008 22:59
VB script to save JPG (photopaint12) tonywong Corel Photo-Paint VBA 2 17-05-2005 08:27
Can I create CustomShape with VBA for CD? Can I create tool? Jab CorelDRAW/Corel DESIGNER VBA 0 01-02-2005 05:02


All times are GMT -5. The time now is 08:04.


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