Public Sub SaveAsDerived()

'written by and property of Sean Dotson, copyright 2006
'if you plan to use this code be my guest, just drop me a line
'to let me know you are...

'declare the environment
Dim oApp As Application
Dim oCurrentDoc As Document
Dim oNewDoc As Document
Dim UseDefaultTemplate As Boolean
Dim sCurrentFileName As String
Dim sTemplatePart As String

Set oApp = ThisApplication
Set oCurrentDoc = oApp.ActiveDocument
   
Select Case oApp.ActiveDocumentType

Case kAssemblyDocumentObject, kPartDocumentObject

    sCurrentFileName = ThisApplication.ActiveDocument.FullFileName
   
    If sCurrentFileName = "" Then
        MsgBox "The active file must first be saved"
        Exit Sub
    End If
   
    'if you want to use the default template then set UseDefaultTemaplte = True
    'if you want to use a custom template set the path and filename of sTemplatePart and UseDefaultTemaplte = False
   
    UseDefaultTemplate = True
    sTemplatePart = "K:\Inventor R9 Templates\_RND\Std Part.ipt"
   
    Select Case UseDefaultTemplate
        Case True
            Set oNewDoc = oApp.Documents.Add(kPartDocumentObject)
        Case False
            Set oNewDoc = oApp.Documents.Add(kPartDocumentObject, sTemplatePart, True)
    End Select

'******START UPDATED CODE **************
'If your template has an active sketch you need to close it.
    Dim oSketch As Sketch
    On Error Resume Next
    Set oSketch = oNewDoc.ComponentDefinition.Sketches.Item(1)
    oSketch.ExitEdit
    On Error Goto 0
'******END UPDATED CODE **************

    'Get the control definition that represents the derived part command.
    Dim oDerivedCommandDef As ControlDefinition
    Set oDerivedCommandDef = ThisApplication.CommandManager.ControlDefinitions.Item("PartDerivedComponentCmd")
   
    'Post the filename to the private event queue.
    Call ThisApplication.CommandManager.PostPrivateEvent(kFileNameEvent, sCurrentFileName)
       
    'Start the derived part command.
    oDerivedCommandDef.Execute

Case Else
    MsgBox "You must first have a Part or Assembly document open"

End Select

End Sub

'******START UPDATED CODE **************
    Dim oSketch As Sketch
    On Error Resume Next
    Set oSketch = oNewDoc.ComponentDefinition.Sketches.Item(1)
    oSketch.ExitEdit
    On Error Goto 0
'******END UPDATED CODE **************