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 19-02-2006, 12:02
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default [DrawX3] RectangleFixer not working!!!

Very useful free macro : RectangleFixer fixes corner radius on non-uniformly scaled rectangles to circular shape. It is not working in DrawX3 but was working in Draw12. I tried to debug it and found that shape.rectangle.SetRadius, setroundness, .radiusLowerLeft etc aren't working in X3 : in watches window nothing changes after lines in bold in following code.
How to overcome? maybe using TransformMatrix which is recorded by VBA-Macro-recorder? But how to calculate this matrix?

Code:
'==================================================================
' MODULE SUMMARY:
'
' "Rectangle Fixer" Copyright © Nicholas Wilkinson 2001-2003
' IsoCalc.com CoolTools: http://www.isocalc.com/cooltools/
' IsoCalc.com Support: http://www.isocalc.com/support/
'....................... ripped by woxxom
            With sRect.Rectangle
                corner_rounds.a = .RadiusLowerLeft
                corner_rounds.b = .RadiusUpperLeft
                corner_rounds.c = .RadiusUpperRight
                corner_rounds.d = .RadiusLowerRight
                
                sRect.Rectangle.SetRoundness 0  ' not workin in X3
                sRect.Rectangle.SetRadius 0  ' not workin in X3
            
                .RadiusLowerLeft = 0  ' not workin in X3
                .RadiusUpperLeft = 0  ' not workin in X3
                .RadiusUpperRight = 0  ' not workin in X3
                .RadiusLowerRight = 0  ' not workin in X3
            End With
        
'....................... ripped by woxxom

Last edited by wOxxOm; 20-03-2006 at 13:35.
Reply With Quote
  #2  
Old 19-02-2006, 13:11
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default

WoW!!!
FIXED this super macro! The only thing needed was using CorelScript.setCornerRoundness 0,0,0,0
But the problem with assigning rectangle corner radius still exists in DrawX3 VBA!

Code:
'==================================================================
' MODULE SUMMARY:
'
' "Rectangle Fixer" Copyright © Nicholas Wilkinson 2001-2003
' IsoCalc.com CoolTools: http://www.isocalc.com/cooltools/
' IsoCalc.com Support: http://www.isocalc.com/support/
'
' Version 1.3, 2003-02-26.
'
' This replaces all the selected rectangles with original
' copies that are not stretched. However, they will be
' skewed and rotated as per the existing rectangles. This
' fixes the problem of 'stretched' rectangles not having
' truly round corners.
'==================================================================

Option Explicit

Private Const pi As Double = 3.14159265358979

Private Type coord
    X As Double
    Y As Double
End Type

Private Type corner_rounds_type
    a As Double
    b As Double
    c As Double
    d As Double
End Type
   
'Get SHIFT-State Routine
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Const VK_SHIFT = &H10

'This is the main Rectangle Fixer function. This is the one that you
'should assign to a toolbar button, menu, or shortcut key
Public Sub RectangleFixer()
    Dim Corners(4) As coord
    Dim corner_rounds As corner_rounds_type
    Dim lNShapes As Long
    Dim lNRectangles As Long
    Dim lcount As Long
    Dim sRect As Shape, sNewRect As Shape
    Dim sShapes As Shapes
    Dim sRange As ShapeRange
    Dim dBaselineAngle As Double
    Dim dSkewAngle As Double
    Dim dWidth As Double, dHeight As Double
    Dim Pos As coord
    Dim aDoc As Document
    Dim blShift As Boolean, i As Long, cs As Object
    
    Set cs = CorelScript
    blShift = GetShiftState()
    
    lNShapes = ActiveSelection.Shapes.Count
    lNRectangles = 0
    
    Set aDoc = ActiveDocument
    
    'Make sure that at least one shape is selected
    If lNShapes = 0 Then
        MsgBox "You must select at least one rectangle.", vbExclamation
        Exit Sub
    End If
    
    aDoc.ReferencePoint = cdrCenter
    Set sRange = ActiveSelectionRange
    
    aDoc.BeginCommandGroup "Fix Rectangles"
    
    'Step through the shapes looking for rectangles
    For lcount = 1 To lNShapes
        If sRange(lcount).Type = cdrRectangleShape Then
           Set sRect = sRange(lcount)
           If sRect.Rectangle.RadiusLowerLeft <> 0 And sRect.Rectangle.RadiusUpperLeft <> 0 And _
              sRect.Rectangle.RadiusUpperRight <> 0 And sRect.Rectangle.RadiusLowerRight <> 0 Then
            
            'If SHIFT was pressed, duplicate the rectangle
            If blShift = True Then
                Set sRect = sRange(lcount).Duplicate
            Else
                Set sRect = sRange(lcount)
            End If
            
            'Get the existing radii of the rectangles corners
            'and then set them to zero
            With sRect.Rectangle
                corner_rounds.a = .CornerLowerLeft + 1: corner_rounds.b = .CornerUpperLeft + 1
                corner_rounds.c = .CornerUpperRight + 1: corner_rounds.d = .CornerLowerRight + 1
                cs.SetCornerRoundness 0, 0, 0, 0
            End With
        
            'Increment the number of rectangles, then convert to curves
            lNRectangles = lNRectangles + 1
            sRect.ConvertToCurves
            
            If sRect.Type = cdrCurveShape Then
            
                'Get the positions of the corner nodes
                Call sRect.Curve.Nodes(1).GetPosition(Corners(0).X, Corners(0).Y)
                Call sRect.Curve.Nodes(2).GetPosition(Corners(1).X, Corners(1).Y)
                Call sRect.Curve.Nodes(3).GetPosition(Corners(2).X, Corners(2).Y)
                Call sRect.Curve.Nodes(4).GetPosition(Corners(3).X, Corners(3).Y)
                
                'Calculate the base (rotation) and skew angles
                dBaselineAngle = DegArcTan(Corners(1).Y - Corners(0).Y, _
                                           Corners(1).X - Corners(0).X, True)
                dSkewAngle = eMod(DegArcTan(Corners(2).Y - Corners(1).Y, _
                                  Corners(2).X - Corners(1).X, True) - dBaselineAngle + 90, 180)
                                  
                'Mustn't let the angle be greater than 90°
                If dSkewAngle > 90 Then dSkewAngle = dSkewAngle - 180
                
                'Get the position of the existing rectangle (center point)
                Call sRect.GetPosition(Pos.X, Pos.Y)
                
                'Calculate the width and height of the base rectangle
                dWidth = Pythagoras(Corners(0), Corners(1))
                dHeight = Pythagoras(Corners(1), Corners(2)) * DegCos(dSkewAngle)
                
                'Create the new rectangle
                Set sNewRect = sRect.Layer.CreateRectangle( _
                     Pos.X - dWidth / 2, Pos.Y - dHeight / 2, _
                     Pos.X + dWidth / 2, Pos.Y + dHeight / 2, _
                     corner_rounds.a, corner_rounds.b, corner_rounds.c, corner_rounds.d)
                
                'Apply a suitable skew and rotation to the new rectangle
                Call sNewRect.Skew(dSkewAngle, 0)
                Call sNewRect.Rotate(dBaselineAngle)
                
                Call copy_outline(sNewRect, sRect)
                Call copy_fill(sNewRect, sRect)
                sNewRect.OrderFrontOf sRect
                
                'And delete the original (now curves) rectangle
                sRect.Delete
                
            Else
                'Report any failed convert-to-curves of rectangles
                MsgBox "Unable to convert a rectangle to curves.", vbExclamation
            End If
          End If ' corner roundness =0
        End If ' not rectangle
notRounded:
    Next lcount
    
    'Finish the UNDO GROUP
    aDoc.EndCommandGroup
    
End Sub

'Returns the modulus of A/B (i.e. the remainder)
Private Function eMod(dValueA As Double, dValueB As Double) As Double
    eMod = dValueA - (dValueB * Fix(dValueA / dValueB))
End Function

'Returns the Cosine of the given DEGREES angle: much easier
'to debug degrees angles rather than radians
Private Function DegCos(dAngle As Double) As Double
    DegCos = Cos(dAngle * pi / 180)
End Function

'Returns the ArcTan of the given 'opposite/adjacent' triangle in DEGREES
Private Function DegArcTan(dNumerator As Double, Optional dDenominator As Double = 1, Optional blLimitTo180 As Boolean = False) As Double
    If dDenominator = 0 Then
        DegArcTan = Sgn(dNumerator) * 90
    Else
        If blLimitTo180 = True Then
            DegArcTan = Atn(dNumerator / dDenominator) * 180 / pi
        Else
            DegArcTan = 90 - Sgn(dDenominator) * 90 + Atn(dNumerator / dDenominator) * 180 / pi
        End If
    End If
End Function

'Calculates hypoteneuse of a right-angled triangle by the two shorter sides
Private Function Pythagoras(point1 As coord, point2 As coord) As Double
    Pythagoras = Sqr((point1.X - point2.X) ^ 2 + (point1.Y - point2.Y) ^ 2)
End Function

'Returns whether the SHIFT key is pressed or not
Private Function GetShiftState() As Boolean
    Call GetAsyncKeyState(VK_SHIFT)
    If GetAsyncKeyState(VK_SHIFT) <> 0 Then GetShiftState = True
End Function

'Copies the outline of one shape to another shape
Private Sub copy_outline(to_shape As Shape, from_shape As Shape)
    Dim from_outline As Outline, to_outline As Outline
    Set from_outline = from_shape.Outline
    Set to_outline = to_shape.Outline
        
    to_outline.BehindFill = from_outline.BehindFill
    If to_shape.Type = cdrCurveShape And from_shape.Type = cdrCurveShape Then
        If to_shape.Curve.Closed = False And from_shape.Curve.Closed = False Then
            to_outline.EndArrow = from_outline.EndArrow
            to_outline.StartArrow = from_outline.StartArrow
        End If
    End If
    to_outline.LineCaps = from_outline.LineCaps
    to_outline.LineJoin = from_outline.LineJoin
    to_outline.NibAngle = from_outline.NibAngle
    to_outline.NibStretch = from_outline.NibStretch
    to_outline.ScaleWithShape = from_outline.ScaleWithShape
    to_outline.Style = from_outline.Style
    to_outline.Type = from_outline.Type
    to_outline.Width = from_outline.Width
    If to_outline.Type = cdrOutline Then
        to_outline.Color = from_outline.Color
    End If
End Sub

'Copies the fill of one shape to another shape
Private Function copy_fill(to_shape As Shape, from_shape As Shape) As Boolean
    to_shape.Fill = from_shape.Fill
    copy_fill = True
End Function

Last edited by wOxxOm; 20-03-2006 at 13:36.
Reply With Quote
  #3  
Old 14-03-2006, 14:59
daniello
Guest
 
Posts: n/a
Default

Hi,

I made a gms from your macro .. and it doesn't work here. Just turnes the rectangle to curve. Is there any chance I made a mistake ?

Daniel
Reply With Quote
  #4  
Old 20-03-2006, 13:37
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default Fixed

Quote:
Originally Posted by daniello
Hi,

I made a gms from your macro .. and it doesn't work here. Just turnes the rectangle to curve. Is there any chance I made a mistake ?

Daniel
fixed, new macro is updated in original post
Reply With Quote
  #5  
Old 20-03-2006, 21:11
Alex's Avatar
Alex Alex is offline
Administrator
 
Join Date: Nov 2002
Posts: 1,940
Blog Entries: 4
Default

Ok, here is my take on it. I have created a new one using the new and cool CorelDRAW X3 features (such as virtual shapes, transformation matrices, etc). This macro works faster now and it's more reliable (I think). It also has a benefit of even fixing rectangles which are part of interactive effects such as blends or extrudes.

As with the original, holding down the Shift key while running the macro will create a copy of each rectangle being fixed. Otherwise the rectangle is fixed in place of the old one...

If you have any questions or comments, let me know.

Code:
Option Explicit

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Const VK_SHIFT = &H10

Sub RectangleFixer()
    Dim sRect As Shape
    Dim nNumRect As Long
    Dim bDuplicate As Boolean
    
    If ActiveShape Is Nothing Then
        MsgBox "There is no selection", vbCritical
        Exit Sub
    End If
    
    nNumRect = 0
    bDuplicate = GetShiftState()
    For Each sRect In ActiveSelection.Shapes.FindShapes(Type:=cdrRectangleShape)
        If FixRectangle(sRect, bDuplicate) Then
            nNumRect = nNumRect + 1
        End If
    Next sRect
    
    If nNumRect > 0 Then
        MsgBox nNumRect & " rectange(s) fixed", vbInformation
    Else
        MsgBox "No transformed rectangles with round corners found", vbInformation
    End If
End Sub

Private Function GetShiftState() As Boolean
    Call GetAsyncKeyState(VK_SHIFT)
    If GetAsyncKeyState(VK_SHIFT) <> 0 Then GetShiftState = True
End Function

Private Function FixRectangle(ByVal sRect As Shape, ByVal bDuplicate As Boolean) As Boolean
    Dim bFixed As Boolean, bHasRoundCorners As Boolean
    Dim sDup As Shape
    Dim r1 As Double, r2 As Double, r3 As Double, r4 As Double
    Dim d11 As Double, d12 As Double, d21 As Double, d22 As Double
    Dim i11 As Double, i12 As Double, i21 As Double, i22 As Double
    Dim det As Double
    Dim x As Double, y As Double
    Dim sx As Double, sy As Double
    
    bFixed = False
    ' Check if the rectangle was actually stretched
    sx = sRect.AbsoluteHScale
    sy = sRect.AbsoluteVScale
    r1 = sRect.Rectangle.CornerUpperLeft
    r2 = sRect.Rectangle.CornerUpperRight
    r3 = sRect.Rectangle.CornerLowerLeft
    r4 = sRect.Rectangle.CornerLowerRight
    bHasRoundCorners = (r1 <> 0) Or (r2 <> 0) Or (r2 <> 0) Or (r2 <> 0)
    If (Abs(sx - 1) > 0.00001 Or Abs(sy - 1) > 0.00001) And bHasRoundCorners Then
        ' Make a temporary copy of the rectangle
        Set sDup = sRect.TreeNode.GetCopy().VirtualShape
        sDup.GetMatrix d11, d12, d21, d22, x, y
        ' Remove skew and rotation from the object temporarily
        d11 = d11 / sx
        d12 = d12 / sy
        d21 = d21 / sx
        d22 = d22 / sy
        det = d11 * d22 - d12 * d21
        i11 = d22 / det
        i12 = -d12 / det
        i21 = -d21 / det
        i22 = d11 / det
        sDup.AffineTransform i11, i12, i21, i22, 0, 0
        ' Get the unrotated/unskewed size
        sDup.GetBoundingBox x, y, sx, sy
        sDup.Delete
        Set sDup = ActiveVirtualLayer.CreateRectangle(x, y, x + sx, y + sy, r1, r2, r3, r4)
        sDup.Fill.CopyAssign sRect.Fill
        sDup.Outline.CopyAssign sRect.Outline
        sDup.AffineTransform d11, d12, d21, d22, 0, 0
        If bDuplicate Then
            sDup.TreeNode.MoveBefore sRect.TreeNode
            ActiveDocument.LogCreateShape sDup
        Else
            sRect.ReplaceWith sDup
        End If
        bFixed = True
    End If
    FixRectangle = bFixed
End Function
Reply With Quote
  #6  
Old 21-03-2006, 09:59
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default

Quote:
Originally Posted by Alex
Ok, here is my take on it.
You're unbelievably cool d00de !!!!!!!!!
thanx
Reply With Quote
  #7  
Old 12-11-2007, 12:41
kliv
Guest
 
Posts: n/a
Default

Sorry to bother you...
What do I do with Alex's code? Tried putting in "recorder macros" after e recorder one, also tried putting it in "corel macros" - after I save and go in corel draw, select a rectangle and go to visual basic - play, I find the macro but doesn't allow me to run (it's a grey button).


Next day edit...
I managed to move a few things in vbasic in corel macros and it works.

Last edited by kliv; 13-11-2007 at 05:07.
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
Working with complex documents easier Alex FAQ 1 30-04-2006 06:28
Curveworks Fillet Not Working For Me wetpuppy CurveWorks 3 02-08-2005 12:21
Round Corners - not always working vallentin Macros/Add-ons 1 15-03-2004 18:50
SaveAs function not working in PP11 Aneurysm Corel Photo-Paint VBA 2 03-03-2003 17:31
Image effects not working. kaliatech Corel Photo-Paint VBA 1 17-01-2003 13:51


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


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