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

[shelbym]

This should do what you want I think:

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

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

[shelbym]

Your thanks is payment enough! Enjoy!

-Shelby

[Alex]

This one is just for fun

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

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

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

[Alex]

Yes, you can. For example, using Shelby's 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

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

[shelbym]

I get to correct code from Alex :-) You just need to change the s to sr in that line like so:

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

You guys are so cool

Thanks a lot - works great.

Kyle