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 06-02-2012, 07:21
ajesion
Guest
 
Posts: n/a
Default Pivot point of two guides

Could I request a macro code that will set the pivot point of two guides in their place of intersection.
Reply With Quote
  #2  
Old 06-02-2012, 13:24
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 Guide Intersects

To make this work, I needed to create line segments based of the guides. If you select two guidelines and run the macro it should do what you want.

There are no error handlers in the code so if you select to many shapes or the shapes are not guidelines you will get errors or incorrect results. Oh, and it will only work if the intersection of the guideline is within your page boundaries.

Code:
Sub GuideIntersects()
    Dim sr As ShapeRange
    Dim cps As CrossPoints
    Dim sGuide1 As Shape, sGuide2 As Shape
    Dim g1X1 As Double, g1Y1 As Double, g1X2 As Double, g1Y2 As Double
    Dim g2X1 As Double, g2Y1 As Double, g2X2 As Double, g2Y2 As Double
    
    Set sr = ActiveSelectionRange
    
    sr(1).Guide.GetPoints g1X1, g1Y1, g1X2, g1Y2
    Set sGuide1 = ActiveVirtualLayer.CreateLineSegment(g1X1, g1Y1, g1X2, g1Y2)
    sr(2).Guide.GetPoints g2X1, g2Y1, g2X2, g2Y2
    Set sGuide2 = ActiveVirtualLayer.CreateLineSegment(g2X1, g2Y1, g2X2, g2Y2)
    
    Set cps = sGuide1.Curve.Segments(1).GetIntersections(sGuide2.Curve.Segments(1))
    
    sr(1).RotationCenterX = cps(1).PositionX
    sr(1).RotationCenterY = cps(1).PositionY
    sr(2).RotationCenterX = cps(1).PositionX
    sr(2).RotationCenterY = cps(1).PositionY
   
    sGuide1.Delete
    sGuide2.Delete
End Sub
Hope it helps,

-Shelby

Last edited by shelbym; 06-02-2012 at 13:27.
Reply With Quote
  #3  
Old 06-02-2012, 15:07
ajesion
Guest
 
Posts: n/a
Default

Thank you very much.
Reply With Quote
  #4  
Old 09-02-2012, 17:52
ajesion
Guest
 
Posts: n/a
Default Guide Intersects

The macro works, but code is not too complicated? Thanks again and best regards.
Code:
Sub GuideIntersects() 
ActiveDocument.SaveSettings
ActiveDocument.Unit = cdrMillimeter
    Dim pw As Double, ph As Double
    Dim sr As ShapeRange
    Dim s As Shape
    Dim cps As CrossPoints
    Dim sGuide1 As Shape, sGuide2 As Shape
    Dim g1X1 As Double, g1Y1 As Double, g1X2 As Double, g1Y2 As Double
    Dim g2X1 As Double, g2Y1 As Double, g2X2 As Double, g2Y2 As Double
ActiveDocument.ActivePage.GetSize pw, ph
If ActiveDocument.SelectionInfo.Count > 2 Then
    MsgBox "Select two intersecting guides.", vbInformation, "GuideIntersects"
    Exit Sub
ElseIf ActiveDocument.SelectionInfo.Count = 2 Then
    Set sr = ActiveSelectionRange
        For Each s In sr
            If s.Type <> cdrGuidelineShape Then
                MsgBox " Select two intersecting guides.", vbInformation, "GuideIntersects"
                Exit Sub
            End If
        Next s
ElseIf ActiveDocument.SelectionInfo.Count = 1 Then
    ActivePage.Shapes.All.CreateSelection
    Set sr = ActiveSelectionRange
        For Each s In sr
            If s.Type <> cdrGuidelineShape Then s.RemoveFromSelection
        Next s
        If ActiveDocument.SelectionInfo.Count <> 2 Then
            MsgBox "Select two intersecting guides.", vbInformation, "GuideIntersects"
            Exit Sub
        End If
ElseIf ActiveDocument.SelectionInfo.Count = 0 Then
    ActivePage.Shapes.All.CreateSelection
    Set sr = ActiveSelectionRange
        For Each s In sr
            If s.Type <> cdrGuidelineShape Then s.RemoveFromSelection
        Next s
        If ActiveDocument.SelectionInfo.Count <> 2 Then
            MsgBox "Select two intersecting guides.", vbInformation, "GuideIntersects"
            Exit Sub
        End If
End If
ActiveDocument.Pages(0).SetSize 45720, 45720 'max mm Corel X4
    Set sr = ActiveSelectionRange
        sr(1).Guide.GetPoints g1X1, g1Y1, g1X2, g1Y2
    Set sGuide1 = ActiveVirtualLayer.CreateLineSegment(g1X1, g1Y1, g1X2, g1Y2)
        sr(2).Guide.GetPoints g2X1, g2Y1, g2X2, g2Y2
    Set sGuide2 = ActiveVirtualLayer.CreateLineSegment(g2X1, g2Y1, g2X2, g2Y2)
If sGuide1.DisplayCurve.IntersectsWith(sGuide2.DisplayCurve) Then
    Set cps = sGuide1.Curve.Segments(1).GetIntersections(sGuide2.Curve.Segments(1))
        sr(1).RotationCenterX = cps(1).PositionX
        sr(1).RotationCenterY = cps(1).PositionY
        sr(2).RotationCenterX = cps(1).PositionX
        sr(2).RotationCenterY = cps(1).PositionY
    sGuide1.Delete
    sGuide2.Delete
Else
    sGuide1.Delete
    sGuide2.Delete
    ActiveDocument.Pages(0).SetSize pw, ph
    ActiveWindow.ActiveView.ToFitPage
    ActiveDocument.RestoreSettings
    Application.Refresh
    ActiveWindow.Refresh
    MsgBox " The intersection point outside the maximum area or no point.", vbInformation, "GuideIntersects"
    Exit Sub
End If
ActiveDocument.Pages(0).SetSize pw, ph
ActiveWindow.ActiveView.ToFitPage
    ActiveDocument.RestoreSettings
    Application.Refresh
    ActiveWindow.Refresh
End Sub
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
Centre Artistic text on point nic CorelDRAW/Corel DESIGNER VBA 5 23-05-2010 17:46
double click to add point.. flyer CorelDRAW/Corel DESIGNER VBA 5 13-12-2007 16:54
Add function to 3 point arc macro simplicitylabs CorelDRAW/Corel DESIGNER VBA 3 07-05-2007 00:45
Pick a Point met CorelDRAW/Corel DESIGNER VBA 1 02-11-2005 07:31
how to read point position (x/y) of any shape with VB-addin Andi CorelDRAW/Corel DESIGNER VBA 1 09-09-2004 08:32


All times are GMT -5. The time now is 18:40.


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