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.

[shelbym]

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.

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

Thank you very much.

The macro works, but code is not too complicated? Thanks again and best regards.

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