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 04-03-2009, 10:31
fungel
Guest
 
Posts: n/a
Default 4mm rectangle around the object

hi.
i am trying to create macro to automate creating a rectange 4 mm around an object (probably adding rectangle by holding down shift, double clicking on rectangle tool, then using Expand/Reduce to expand by 4 mm). I cannot get macro to work...

Can anybody help? Does anyone have code?

Regards,

Kyle
Reply With Quote
  #2  
Old 04-03-2009, 13:31
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 Something like this....

This should do what you want I think:
Code:
Sub CreateBoundingRect()
    Const ExpandBy As Double = 4
    Dim s As Shape
    Dim x As Double, y As Double, w As Double, h As Double
 
    ActiveDocument.ReferencePoint = cdrBottomLeft
    ActiveDocument.Unit = cdrMillimeter
    
    Set s = ActiveSelection
    s.GetBoundingBox x, y, w, h
    
    ActiveLayer.CreateRectangle2 x - ExpandBy, y - ExpandBy, s.SizeWidth + (ExpandBy * 2), s.SizeHeight + (ExpandBy * 2)
End Sub
Best of luck,

-Shelby
Reply With Quote
  #3  
Old 05-03-2009, 04:16
fungel
Guest
 
Posts: n/a
Default That's great thanks.

That is exactly what i was looking for!! Ta very much!.

Hey how can i donate money to you? i find this forum excellent and has improved my efficiency loads as well as my end product for my customers

Ta.

Kyle
Reply With Quote
  #4  
Old 05-03-2009, 09:26
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 Thanks....

Your thanks is payment enough! Enjoy!

-Shelby
Reply With Quote
  #5  
Old 05-03-2009, 10:12
Alex's Avatar
Alex Alex is offline
Administrator
 
Join Date: Nov 2002
Posts: 1,940
Blog Entries: 4
Default

This one is just for fun

In Designer X4 and a future version of CorelDRAW you'll be able to do this as follows:

Code:
Sub CreateBoundingRect2()
    Const ExpandBy As Double = 4
    Dim rc As Rect
 
    ActiveDocument.Unit = cdrMillimeter
    Set rc = ActiveSelection.BoundingBox
    rc.Inflate ExpandBy, ExpandBy, ExpandBy, ExpandBy
    ActiveLayer.CreateRectangleRect rc
End Sub
A bit simpler, I guess
Reply With Quote
  #6  
Old 05-03-2009, 14:04
fungel
Guest
 
Posts: n/a
Default Erm.... if it's not too much to ask....

Hey guys, those codes work great so Big thanks to you guys.

I was just wondering if after the rectangle is created would it be possible to group the orginal object with the rectangle?

Kyle
Reply With Quote
  #7  
Old 05-03-2009, 16:17
Alex's Avatar
Alex Alex is offline
Administrator
 
Join Date: Nov 2002
Posts: 1,940
Blog Entries: 4
Default

Yes, you can. For example, using Shelby's code:

Code:
Sub CreateBoundingRect()
    Const ExpandBy As Double = 4
    Dim sr As ShapeRange
    Dim s As Shape
    Dim x As Double, y As Double, w As Double, h As Double
 
    ActiveDocument.Unit = cdrMillimeter
    
    Set sr = ActiveSelectionRange
    sr.GetBoundingBox x, y, w, h
    
    sr.Add ActiveLayer.CreateRectangle2(x - ExpandBy, y - ExpandBy, s.SizeWidth + (ExpandBy * 2), s.SizeHeight + (ExpandBy * 2))
    sr.Group
End Sub
Reply With Quote
  #8  
Old 05-03-2009, 17:15
fungel
Guest
 
Posts: n/a
Default Problem with macro

Hi Alex. Many thanks for your time..

Unfortunately the macro which should group both the orginal object and the rectangle together does not work.

The problem was with the following line near the bottom:
sr.Add ActiveLayer.CreateRectangle2(x - ExpandBy...............................

Ta.

Kyle
Reply With Quote
  #9  
Old 05-03-2009, 17:29
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 This is a first...

I get to correct code from Alex :-) You just need to change the s to sr in that line like so:
Code:
Sub CreateBoundingRect()
    Const ExpandBy As Double = 4
    Dim sr As ShapeRange
    Dim x As Double, y As Double, w As Double, h As Double
 
    ActiveDocument.Unit = cdrMillimeter
    
    Set sr = ActiveSelectionRange
    sr.GetBoundingBox x, y, w, h
    
    sr.Add ActiveLayer.CreateRectangle2(x - ExpandBy, y - ExpandBy, sr.SizeWidth + (ExpandBy * 2), sr.SizeHeight + (ExpandBy * 2))
    sr.Group
End Sub
Best of luck,

-Shelby
Reply With Quote
  #10  
Old 06-03-2009, 02:28
fungel
Guest
 
Posts: n/a
Default Genius!!

You guys are so cool

Thanks a lot - works great.

Kyle
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
Selecting shapes in rectangle area lukswa CorelDRAW/Corel DESIGNER VBA 2 07-10-2008 02:13
Create Rectangle-Shape with positioning WernerHo CorelDRAW/Corel DESIGNER VBA 2 06-02-2008 03:40
draw nodes at crossing point between a line and a rectangle joyJOYJOY Corel Photo-Paint VBA 1 01-08-2007 13:18
Checking If Artistic Text is on a rectangle shape knowbodynow CorelDRAW/Corel DESIGNER VBA 2 16-04-2007 17:47
Tiler-Script, bounding rectangle + CorelDraw 11 Layout-herber CorelDRAW CS 3 24-01-2003 01:40


All times are GMT -5. The time now is 17:41.


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