Thread: Mirror shapes View Single Post
#1
16-01-2011, 19:50
 runflacruiser Senior Member Join Date: Jun 2009 Location: Pigeon Forge, TN USA Posts: 811
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