GDG Code Chunks, Discussion, VBA Snippets for CorelDRAW, Simple Macro Helpers!

cool vba macros for corel show cart gdg corel draw macros checkoutMyAccount corel macros
VBA Corel Macro Help
john's macros
thanks for stopping by gdg macros















Helpful VBA Code
NEW. GDG Macros Suite 2023.
Please note: Macros 2023 (and above if their will be any) will no longer be sold separately.
Join me on Facebook to stay up to date with news, updates. Subscribe to my YouTube Channel for tutorial videos and tips. Need a custom macro? Contact me.
Not all macros are guaranteed to be continued due to compatibility reasons or other. Read new-version policy here.
I appreciate everyone! Upgrading macros and maintaining this site is quite a task for me. Want to contribute? Please DONATE
^ Hide these messages to save screen space ^

<<Back to helpful code list

Quick flip a shape to the other side of a line - Mirror Flip Shape

Decription: Select a shape and then a line. Shape will be flipped to the other side of the line no matter what angle the line is.

Date: 2011-01-21 Author: 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





Forget it...Go back
Title for your entry:
(optional)
Comment/Suggestion:
(optional)
Your Name:
(optional)

Please enter the numbers shown below..
This is to make sure your human.
(required)
 





Title: Super Mirror Many Shapes
Comment left by: capacitor
Date: 2015-02-26
Comment left:
Private Const VK_SHIFT = &H10

Sub SuperMirror()
Dim sr#, sRX#, sRY#, mR#, mRX#, mRY#, x#, y#, x1#, y1#, w1#, h1#, mx#, my#, sx#, sy#, _
Shift As Long, B As Boolean, G As Boolean, N As Boolean, smith As Shape, mySh As Shape, dup1 As Shape, p#

On Error GoTo TheEnd

B = True: G = False: N = False \'G(grouped), N(smith selected)
ActiveDocument.ReferencePoint = cdrCenter

If ActiveShape Is Nothing Then
MsgBox (\"No shapes selected\"), vbCritical
Exit Sub
End If

ActiveDocument.BeginCommandGroup \"S-Mirror\"

Optimization = True

If ActiveSelection.Type = cdrGroupShape Then
G = False: GoTo 1001 \'is group detected
End If

If ActiveSelection.Shapes.Count > 1 Then
ActiveSelection.Group
G = True \'group them
End If

1001:

Set mySh = ActiveShape
mySh.GetPosition mx, my

If B Then
   B = ActiveDocument.GetUserClick(x, y, Shift, 15, False, 309)  \'cdrCursorEyeDrop
   Set smith = ActivePage.SelectShapesAtPoint(x, y, True)
   If ActiveShape Is Nothing Then Beep: N = True: GoTo TheEnd
   Set smith = smith.Shapes.Last
End If
  
  sRX = smith.RotationCenterX
  sRY = smith.RotationCenterY
  sr = smith.RotationAngle
  smith.RotationAngle = 0
  smith.GetPosition sx, sy

  p = mx - sx \'posX mySh - posX smith
  
  Set dup1 = mySh.Duplicate
  dup1.Flip cdrFlipHorizontal
  dup1.OrderFrontOf mySh
  
  dup1.PositionX = sx - p

  dup1.RotationCenterX = sRX
  dup1.RotationCenterY = sRY
  
  If GetAsyncKeyState(VK_SHIFT) Then
  dup1.Rotate 180
  End If
  
  dup1.RotationAngle = dup1.RotationAngle   sr * 2
  dup1.GetBoundingBox x1, y1, w1, h1
  smith.RotationAngle = sr
  
  \'recover rotation center points
  dup1.RotationCenterX = x1   (w1 / 2)
  dup1.RotationCenterY = y1   (h1 / 2)
  If G Then dup1.Ungroup: mySh.Ungroup
 
  ActiveDocument.ClearSelection
  Optimization = False
  ActiveDocument.EndCommandGroup
TheEnd:
  If G And N Then dup1.Ungroup: mySh.Ungroup
  Optimization = False
  ActiveWindow.Refresh
  Application.Refresh
  
End Sub \'---------------JRM2014



gdg


Title: mirror shapes
Comment left by: capacitor
Date: 2015-02-24
Comment left:
Sub SuperMirror()
Dim sr#, sRX#, sRY#, mR#, mRX#, mRY#, x#, y#, x1#, y1#, w1#, h1#, mx#, my#, sx#, sy#, _
Shift As Long, B As Boolean, smith As Shape, mySh As Shape, dup1 As Shape, n#

On Error GoTo TheEnd
B = True
ActiveDocument.ReferencePoint = cdrCenter

If ActiveShape Is Nothing Then
MsgBox ("No shapes selected"), vbInformation
Exit Sub
End If

ActiveDocument.BeginCommandGroup "S-Mirror"

Set mySh = ActiveShape
mySh.GetPosition mx, my

If B Then
   B = ActiveDocument.GetUserClick(x, y, Shift, 15, False, 309) 'cdrCursorEyeDrop
   Set smith = ActivePage.SelectShapesAtPoint(x, y, True)
   If ActiveShape Is Nothing Then Beep: GoTo TheEnd:
   Set smith = smith.Shapes.Last
End If
  
  sRX = smith.RotationCenterX
  sRY = smith.RotationCenterY
  sr = smith.RotationAngle
  smith.RotationAngle = 0
  smith.GetPosition sx, sy


  Optimization = True
  
  n = mx - sx 'posX mySh - posX smith
  
  Set dup1 = mySh.Duplicate
  dup1.Flip cdrFlipHorizontal
  dup1.OrderFrontOf mySh
  
  dup1.PositionX = sx - n

  dup1.RotationCenterX = sRX
  dup1.RotationCenterY = sRY
  
  If GetAsyncKeyState(VK_SHIFT) Then
  dup1.Rotate 180
  End If
  
  'if not ignore smith rotation
  dup1.RotationAngle = dup1.RotationAngle + sr * 2
  dup1.GetBoundingBox x1, y1, w1, h1
  smith.RotationAngle = sr
  
  'recover rotation center points
  dup1.RotationCenterX = x1 + (w1 / 2)
  dup1.RotationCenterY = y1 + (h1 / 2)

  ActiveDocument.ClearSelection
  Optimization = False
  ActiveDocument.EndCommandGroup
TheEnd:
  Optimization = False
  ActiveWindow.Refresh
  Application.Refresh

End Sub



gdg






corel macros boost workflow
*Searches the FREE and Commercial Macros


CorelDraw macros for version 2023

CorelDraw macros for version 2020

CorelDraw macros for version 2019

CorelDraw macros for version 2018

CorelDraw macros for version 2017

macros for coreldraw x8

macros for coreldraw x7

macros for corel draw x6

macros for corel draw x6

FIND IT ON

find it on yahoo

FIND IT ON

find it on google