OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > Code Critique

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 16-01-2011, 18:50
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default Mirror shapes

Hi.
Here's my take on a recent post about mirroring shapes to the other side of a line segment. Line segment can be at any angle. Shape will be duplicated/mirrored to the other side. Similar to an Autocad feature.

-John

Code:
Option Explicit

Sub mirrorIt() 'begin
    flipIt
End Sub

Private Sub flipIt()
    Dim sr As ShapeRange, s1 As Shape, leftOrRight As String
    Dim x As Double, y As Double, w As Double, h As Double
    Dim xC As Double, yC As Double, dS2L As Double
    Dim s As Shape, s2 As Shape, angle As Double, sNew As Shape
    Dim srFinal As ShapeRange
    Set sr = getSelectionShapes()
    If sr.count <> 2 Then Exit Sub
    ActiveDocument.BeginCommandGroup "flipIt"
    sr.GetBoundingBox x, y, w, h
    Set s1 = sr(1)
    Set s2 = sr(2)
    If s2.Type <> cdrCurveShape Then s2.ConvertToCurves
    s2.Curve.Segments(1).GetPointPositionAt xC, yC, 0.5
    'get angle of rotation using function that gets perpendicular angle from line segment.
    angle = getAngle(s2) * -1
    Set s = sr.Group
    'get center rotation point which we use now and when rotating back
    'rotation put is in the middle of line segment.
    s.RotationCenterX = xC: s.RotationCenterY = yC
    s.Rotate angle
    If s1.CenterX < s2.CenterX Then 'flip the duplicate shapes left or right based on the items horizontal position.
        leftOrRight = "r"
    Else
        leftOrRight = "l"
    End If
    s.Ungroup
    sr.AddRange flipSide(sr, leftOrRight) 'flip in the flip funcction!
    sr.RotationCenterX = xC: sr.RotationCenterY = yC
    sr.Rotate -angle 'rotate both back to original palce
    ActiveSelection.Ungroup
    ActiveDocument.EndCommandGroup
End Sub

Private Function flipSide(ByRef sr As ShapeRange, rl As String) As ShapeRange

Dim s1 As Shape, sDup As Shape
Dim x1 As Double, y1 As Double, w1 As Double, h1 As Double 'entire selection shape
Set flipSide = CreateShapeRange

sr.GetBoundingBox x1, y1, w1, h1
ActiveDocument.ReferencePoint = cdrBottomLeft
Set sDup = sr.Group.Duplicate
sDup.Flip cdrFlipHorizontal
If rl = "r" Then
    sDup.SetPosition x1 + w1, y1
Else
    sDup.SetPosition x1 - w1, y1
End If
sDup.CreateSelection
Set flipSide = sDup.UngroupEx

End Function

Private Function getSelectionShapes() As ShapeRange
    Dim shift As Long
    Dim bClick As Boolean
    Dim s As Shape
    Dim x As Double, y As Double
    Dim dTol As Double
    dTol = 0.1 ' select shape tolerance
    ActiveDocument.ClearSelection
    Set getSelectionShapes = CreateShapeRange
    'MsgBox "Select shape first and then line second" '(optional)
retrySelectPath:
    While Not bClick
        bClick = False
        bClick = ActiveDocument.GetUserClick(x, y, shift, 10, False, cdrCursorEyeDrop)
        If Not bClick Then
          Set s = ActivePage.SelectShapesAtPoint(x, y, True, dTol)
        End If
    
        If s.Shapes.count < 1 Then
            Dim mRetry As Integer
            mRetry = MsgBox("No shape selected. Try again?", vbOKCancel, "GDG")
            If mRetry = 1 Then
                GoTo retrySelectPath:
            Else
                Exit Function
            End If
        End If
        getSelectionShapes.Add s.Shapes(1)
        If getSelectionShapes.Shapes.count = 2 Then GoTo exitLoop:
    Wend
exitLoop:
End Function

Private Function getAngle(s As Shape) As Double

    If s.Type <> cdrCurveShape Then s.ConvertToCurves
    getAngle = s.Curve.Segments(1).GetPerpendicularAt(0.5)
    
End Function
Reply With Quote
  #2  
Old 16-01-2011, 21:17
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,769
Blog Entries: 9
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 Free Angle Reflection

Isn't this exactly what the Free Angle Reflection tool is for? It rocks, I use it all the time.

-Shelby
Reply With Quote
  #3  
Old 16-01-2011, 21:20
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

Hmm.
I was pretty sure there was another way.
I think that's one I don't use. Nice little challenge anyways...lol
-John
Reply With Quote
Reply

Tags
autocad mirror, flip, flop, mirror shapes


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
Remove Mirror form All Selected Text vindaa CorelDRAW/Corel DESIGNER VBA 2 12-07-2008 19:47
Naming Shapes shelbym CorelDRAW/Corel DESIGNER VBA 9 03-07-2008 20:12
Iterating through Shapes zoid CorelDRAW/Corel DESIGNER VBA 4 04-07-2007 08:25
Use shapes in a range Manuel CorelDRAW/Corel DESIGNER VBA 1 09-05-2007 13:55
corelDRAW paragraph text mirror "bug" hellraeser General 2 08-03-2006 23:17


All times are GMT -5. The time now is 11:50.


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