Sub CreateNewProject()
    Dim fso As Scripting.FileSystemObject
    Dim BaseFolder As Scripting.folder
    Dim NewFolder As Scripting.folder
    Dim oFile As Scripting.File
    Dim oInvFile As Scripting.File
    Dim oDoc As Document
    Dim oPNProp As Inventor.Property
    
    On Error Resume Next
    SONum = InputBox("Enter the new Sales Order Number", "Create New Project")
    
    Set fso = New Scripting.FileSystemObject
    Set BaseFolder = fso.GetFolder(ActiveWorkbook.Path)
    fso.CopyFolder ActiveWorkbook.Path, BaseFolder.ParentFolder & "\" & SONum
    Set NewFolder = fso.GetFolder(BaseFolder.ParentFolder.Path & "\" & SONum)
    Set oFile = fso.GetFile(NewFolder.Path & "\100G347202 Shell And Tube.ipj")
    oFile.Name = Replace(oFile.Name, "347202", SONum)
    
    Dim oInvApp As Inventor.Application
    Dim oFileLocations As FileLocations
    
    oInvApp.SilentOperation = True
    
    ' Start Inventor
    Err.Clear
    Set oInvApp = GetObject(, "Inventor.Application")
    If Err Then
        Set oInvApp = CreateObject("Inventor.Application")
        Err.Clear
    End If
    Set oFileLocations = oInvApp.FileLocations
    
    ' Check to make sure a document isn't open.
    If oInvApp.Documents.Count > 0 Then
        MsgBox "All documents must be closed before changing the project."
        Exit Sub
    End If
    
    ' Set Project File
    oFileLocations.FileLocationsFile = oFile.Path
    oFileLocations.Workspace = NewFolder.Path
    
    For Each oInvFile In NewFolder.Files
        sExt = LCase(Mid(oInvFile.ShortName, InStr(oInvFile.ShortName, ".") + 1))
        If sExt = "ipt" Or sExt = "iam" Then
            Set oDoc = oInvApp.Documents.Open(oInvFile.Path)
            Set oPNProp = oDoc.PropertySets(3).ItemByPropId(kPartNumberDesignTrackingProperties)
            CurPN = oPNProp.Value
            Debug.Print oInvFile.Name
            Debug.Print CurPN
            If InStr(CurPN, "347202") > 0 Then
                oPNProp.Value = Replace(CurPN, "347202", SONum)
                Debug.Print oPNProp.Value
            End If
            oDoc.Save
            oDoc.Close
        End If
    Next
    
End Sub