Macro exists sketch after projecting origin plane and point - only sometimes...

[z.baczo]

Hi,

Can somebody help me with the macro from below? I's supposed to project the perpendicular origin planes and the origin point into a sketch - if they-re not always there... Which it does nicely, but sometimes - not always - it exists the sketh after it's done projecting the stuff its suppoesd to. Other times it stays in the sketch. Since projectiong the work planes is never the last thing I want to do in a sketch, it would be nice if it always stayed in the sketch after projection.

Now i don't know very much about macros, I cut this piece togeather from several different sources, so I can't figure out what is happening here, so any help would be much appreciated.

And here is the code:

Public Sub PPOP()
' PPOP = ProjectPerpendicularOriginPlane
Dim doc As Document
' This works even if the part document is activated inside
' an assembly and not opened in its own window
Set doc = ThisApplication.ActiveEditDocument

If Not TypeOf doc Is PartDocument Then
Call MsgBox("You need to be inside a part document")
Exit Sub
End If

Dim ao As PlanarSketch
Set ao = ThisApplication.ActiveEditObject

If Not TypeOf ao Is PlanarSketch Then
Call MsgBox("You need to be inside a sketch")
Exit Sub
End If

Dim pd As PartDocument
Set pd = doc

Dim cd As PartComponentDefinition
Set cd = pd.ComponentDefinition

Dim sk As PlanarSketch
Set sk = ao

' The origin planes are the first 3
' in the WorkPlanes collection
Dim i As Integer
For i = 1 To 3
Dim wp As WorkPlane
Set wp = cd.WorkPlanes(i)

' If the WorkPlane was already added
' then AddByProjectingEntity would throw
' an error.
' To avoid that we can do error handling:
On Error Resume Next

If wp.Plane.IsPerpendicularTo(sk.PlanarEntityGeometry) Then
' Checking if the workplane is perpendicular might
' be an overkill because if not, then the below
' function would throw an error.
' But I think it's nicer if we check 🙂
Dim se As SketchEntity
Set se = sk.AddByProjectingEntity(wp)
' Make the line a construction line
se.Construction = True
End If

On Error GoTo 0
Next i

' Projecting origin if origin missing:
On Error Resume Next
Set se = sk.AddByProjectingEntity(cd.WorkPoints(1))

' Get things updated so the new sketch lines show
' even if the part document is modified inside an assembly
ThisApplication.ActiveDocument.Update
End Sub

As far as i can tell, it only exists if I use it on a sketch that I've prevoiuosly exited for some reason and the re-entered and then used the macro - maybe it helps...

Thanks in advance,

Baczo Zsolt.

[Snipercz36]

Hello,

look to my post http://forums.autodesk.com/t5/Inventor-Customization/Create-new-part-sketch-and-rectangle-circle/td-...

There is all you need.

Hope it helps

Best Regards