OberonPlace.com Forums  

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

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 16-11-2006, 20:15
Chester
Guest
 
Posts: n/a
Default Constant area macro or VB?

I use CorelDraw 12 at work to design signs. Very often the area of a sign must conform to local zoning codes which restrict sign dimensions to a given area in square feet. The ability to specify the area of an object and have that remain constant while I stretch or squeeze it would be extremely useful. Is there a way to accomplish this in Corel by using some undocumented key combinations a macro or Visual Basic program? Is this a feature of version X3?

Chester
Reply With Quote
  #2  
Old 17-11-2006, 13:17
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 Constant Area

As far as I know there is no feature to do this. But I think you could get pretty close with VBA. I have not had a lot of time to polish this, but it basically does what you want. Define a shape a FixedAreaShape by running MakeMeFixedArea() while the shape it selected. From then on it will resize itself to get back to the original area. (Area is pretty crude, just w * h, so really it only works well on rectangles.) If you don't want the shape to keep the area any longer run the RemoveFixedArea(). I have only tested this in X3 and have run into a couple times it doesn't want to resize correctly....could be rounding or something.....but I don't have the time right now to dig into it.

Just wanted to prove YES with a little polish you could do this.
Code:
'---------This need to go in Global Macro Storage---------------
Dim WithEvents CurDoc As Document

Private Sub CurDoc_ShapeTransform(ByVal Shape As Shape)
    area.FixedArea Shape
End Sub

Private Sub GlobalMacroStorage_WindowActivate(ByVal Doc As Document, ByVal Window As Window)
    Set CurDoc = Doc
    MsgBox "Active"
End Sub
'--------------------------------------------------------------

'-----------This need to go a Module named: area---------------
Sub MakeMeFixedArea()

Dim s As Shape
Dim w As Double, h As Double
Dim area As Double

Set s = Application.ActiveShape

CheckDataItem ("SizeW")
CheckDataItem ("SizeH")
CheckDataItem ("Area")

s.GetSize w, h
s.Name = "FixedArea"
s.ObjectData("SizeW").Value = Round(w, 3)
s.ObjectData("SizeH").Value = Round(h, 3)
s.ObjectData("Area").Value = Round(Round(w, 3) * Round(h, 3), 3)

End Sub

Sub RemoveFixedArea()

Dim s As Shape

Set s = Application.ActiveShape

s.Name = ""
s.ObjectData("SizeW").Value = ""
s.ObjectData("SizeH").Value = ""
s.ObjectData("Area").Value = ""

End Sub

Sub FixedArea(s As Shape)

Dim w As Double, h As Double
Dim area As Double

If s.Name = "FixedArea" Then

area = s.ObjectData("Area")

    If CDbl(s.ObjectData("SizeH")) <> Round(s.SizeHeight, 3) Then
        MsgBox "Stored H: " & (s.ObjectData("SizeH")) & "Actual: " & Round(s.SizeHeight, 3)
        s.SizeWidth = area / Round(s.SizeHeight, 3)
        s.GetSize w, h
        s.ObjectData("SizeW").Value = Round(w, 3)
        s.ObjectData("SizeH").Value = Round(h, 3)
        s.ObjectData("Area").Value = Round(Round(w, 3) * Round(h, 3), 3)
    ElseIf CDbl(s.ObjectData("SizeW")) <> Round(s.SizeWidth, 3) Then
        MsgBox "SizeW is Different"
        s.SizeHeight = area / Round(s.SizeWidth, 3)
        s.GetSize w, h
        s.ObjectData("SizeW").Value = Round(w, 3)
        s.ObjectData("SizeH").Value = Round(h, 3)
        s.ObjectData("Area").Value = Round(Round(w, 3) * Round(h, 3), 3)
    End If
Else
    Exit Sub
End If

End Sub

Private Sub CheckDataItem(diName As String)

Dim bFound As Boolean
Dim df As DataField

bFound = False

For Each df In ActiveDocument.DataFields
    If df.Name = diName Then
        bFound = True
        Exit For
    End If
Next df

If bFound = False Then ActiveDocument.DataFields.Add diName, , True, True

End Sub
'--------------------------------------------------------------
Well at least it is a start,

Shelby
Reply With Quote
  #3  
Old 17-11-2006, 19:21
Chester
Guest
 
Posts: n/a
Default

Shelby,

Thank you for taking the time to respond to my post and for your macro code.

I must admit that I have no idea of how to use your macro since I know nothing about VB. I will need more information about VB to take advantage of your generous effort. An investigative visit to Barns & Noble is in order.

I'm certain that many more people than just myself would love to have this functionality in the program.

Regards,
Chester
Reply With Quote
  #4  
Old 26-11-2006, 22:10
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 A little easier

Chester I put the code into a GMS file for you. I have only tested this with CorelDRAW X3. Place this file here: "C:\Program Files\Corel\CorelDRAW Graphics Suite 13\Draw\GMS"

Then make sure the Delay VBA is unchecked: Tools| Options| Workspace| VBA| Delay Load VBA

To make it work select a shape like a rectangle. Then run the macro by doing: Tools| Visual Basic| Play MakeMeFixedArea()

Now if you try and resize the rectangle by say the height, the width will change to keep the area what it was. If you want to turn it off for the shape run the other macro.

Hope that makes a little more sense,

Shelby
Attached Files
File Type: gms FixedArea.gms (28.0 KB, 562 views)
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
Cannot use Curveworks macros in a user witten macro??? jon46089 CurveWorks 2 02-03-2006 14:18
Help with Replace Macro Pumpkin_Masher Macros/Add-ons 1 21-09-2005 14:41
Adding a Reference on a pwd protected macro Rick Randall CorelDRAW/Corel DESIGNER VBA 9 27-10-2004 09:27
New macro to clip curves w.r.t. a border Gerard Hermans Macros/Add-ons 0 09-06-2003 07:50
Speeding up a macro Rick Randall CorelDRAW/Corel DESIGNER VBA 2 12-12-2002 10:51


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


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