Decription: This is a modification of code posted by wOxxOm. It now adds ability to create the guidelines inside powerclips and also adds a quick delete sub for the guidelines inside the powerclips. I wrote this quick and didn't do a lot of testing but it works. Modify as needed.
Date: 2010-05-09 Author: wOxxOm, modified by John
Code:
Sub DrawGuideHorizontal2()
Dim p As lpPoint, x As Double, y As Double, l As Layer
Dim pwc As PowerClip
Dim s As Shape, sg As Shape
Dim x1 As Double, y1 As Double, w1 As Double, h1 As Double
GetCursorPos p
ActiveWindow.ScreenToDocument p.x, p.y, x, y
Set s = ActivePage.SelectShapesAtPoint(x, y, True).Group
If Not s Is Nothing Then s.GetBoundingBox x1, y1, w1, h1
Set l = ActiveLayer
Set pwc = Nothing
On Error Resume Next
Set pwc = s.PowerClip
On Error GoTo 0
If Not pwc Is Nothing Then
pwc.EnterEditMode
Set sg = ActiveLayer.CreateLineSegment(x1, y, x1 + w1, y)
sg.Outline.Color.CMYKAssign 100, 0, 0, 0
sg.Outline.SetProperties Style:=OutlineStyles(8), DashDotLength:=0#
sg.Name = "tempGuide"
pwc.LeaveEditMode
Else
1001
ActivePage.Layers("Guides").createGuide x, y, x + 1, y
End If
l.Activate
End Sub
Sub DrawGuideVertical2()
Dim p As lpPoint, x As Double, y As Double, l As Layer
Dim pwc As PowerClip
Dim s As Shape, sg As Shape
Dim x1 As Double, y1 As Double, w1 As Double, h1 As Double
GetCursorPos p
ActiveWindow.ScreenToDocument p.x, p.y, x, y
Set s = ActivePage.SelectShapesAtPoint(x, y, True).Group
If Not s Is Nothing Then s.GetBoundingBox x1, y1, w1, h1
Set l = ActiveLayer
Set pwc = Nothing
On Error Resume Next
Set pwc = s.PowerClip
On Error GoTo 0
If Not pwc Is Nothing Then
pwc.EnterEditMode
Set sg = ActiveLayer.CreateLineSegment(x, y1, x, y1 + h1)
sg.Outline.Color.CMYKAssign 100, 0, 0, 0
sg.Outline.SetProperties Style:=OutlineStyles(8), DashDotLength:=0#
sg.Name = "tempGuide"
pwc.LeaveEditMode
Else
1001
ActivePage.Layers("Guides").createGuide x, y, x + 1, y
End If
l.Activate
End Sub
Sub deleteGuidelinesInPC()
Dim s As Shape, sr As ShapeRange
Dim pwc As PowerClip, sp As Shape
Set sr = ActivePage.FindShapes
For Each s In sr
Set pwc = Nothing
On Error Resume Next
Set pwc = s.PowerClip
On Error GoTo 0
If Not pwc Is Nothing Then
For Each sp In pwc.Shapes.All
If sp.Name = "tempGuide" Then sp.Delete
Next sp
Else
If s.Name = "tempGuide" Then s.Delete
End If
Next s
End Sub
|
MyAccount
