Set Save File Dialog Initial Directory

[Anonymous]

I need a code that Opens a selected Part From an Assembly and so a saves a copy of this new part. Code to open file works good. 

i have a assembly in subfolder of Workspace. I Set the initial directory for Save Dialog to this sub folder, but it always opens the workspace Folder. But the same thing works for OpenFile Dialog. What is wrong with my code.

for eg Suppose C:\_work\Plant_14\Slide\BearingHousing.iam is the FIlepath for assembly, where "_work" is the workspace folder. FileDialog initial directory is "_work" whereas i want "C:\_work\Plant_14\Slide\"

i Work in Inventor 2010 SP4 64Bit Edition.

Thanks

Dim DocFilePath As String
Sub Open_Selected()
    Dim Doc As Document
    Dim obj As Object
    Dim ObjFullfileName As String
    Dim DocType As DocumentTypeEnum
    Dim eLocType As LocationTypeEnum
    Dim DocFullfileName As String
    'Get the active document.
    Set Doc = ThisApplication.ActiveDocument
    
    On Error Resume Next
    DocFullfileName = Doc.Fullfilename
    
    Dim CompFileNameOnly As String
    'get the location of the last backslash
    Dim index As Integer
    index = InStrRev(DocFullfileName, "\")
    
    DocFilePath = Left(DocFullfileName, index - 1)
        
    'Check if any file is open. if nothing is open exit macro.
    Set oDef = Doc.ComponentDefinition
        If Err Then
        ' Unable to get the Parameters object, so exit.
        MsgBox "Unable to access the parameters. An assembly must be Open."
        Exit Sub
    End If
    On Error GoTo 0
    
    'Get Document Type and check wheter it is a part or assembly file, else exit Macro
    
    DocType = Doc.DocumentType
    If DocType = kAssemblyDocumentObject Then
        'Pass
        Else
        MsgBox "File Type Not Compatible. Please Use an Assembly File"
        Exit Sub
    End If
    
    On Error Resume Next
    Set obj = Doc.SelectSet.Item(1)
    If Err Then
        MsgBox "Select Something in an assembly"
    Else
        If (TypeOf obj Is ComponentOccurrence) Then
            Dim occ As ComponentOccurrence
            Set occ = obj
            ObjFullfileName = occ.Definition.Document.Fullfilename
        End If
        Set oDoc = ThisApplication.Documents.Open(ObjFullfileName, True)
        oDoc.Activate
    End If
    TestFileDialog
End Sub

Public Sub TestFileDialog()

 ' Set a reference to the FileLocations object.
    'Dim oFileLocations As FileLocations
    'Set oFileLocations = ThisApplication.FileLocations

    'Dim sPath As String
    'Debug.Print "Workspace: " & oFileLocations.Workspace ' Display the workspace.
    'sPath = oFileLocations.Workspace
 
    ' Create a new FileDialog object.
    Dim oFileDlg As FileDialog
    Call ThisApplication.CreateFileDialog(oFileDlg)

    ' Define the filter to select part and assembly files or any file.
    oFileDlg.Filter = "Inventor Files (*.iam;*.ipt)|*.iam;*.ipt|All Files (*.*)|*.*"

    ' Define the part and assembly files filter to be the default filter.
    oFileDlg.FilterIndex = 1

    ' Set the title for the dialog.
    oFileDlg.DialogTitle = "Open File Test"

    ' Set the initial directory that will be displayed in the dialog.
    oFileDlg.InitialDirectory = DocFilePath 'sPath   '"C:\Temp"
    
    ' Set the flag so an error will be raised if the user clicks the Cancel button.
    oFileDlg.CancelError = True

    ' Show the open dialog.  The same procedure is also used for the Save dialog.
    ' The commented code can be used for the Save dialog.
    On Error Resume Next
    'oFileDlg.ShowOpen
    oFileDlg.ShowSave
    
    ' If an error was raised, the user clicked cancel, otherwise display the filename.
    If Err Then
        MsgBox "User cancelled out of dialog"
    ElseIf oFileDlg.filename <> "" Then
        MsgBox "File " & oFileDlg.filename & " was selected."
    End If
End Sub

Public Sub GetLocation()

 Dim oDoc As Document
 Set oDoc = ThisApplication.ActiveDocument

 Dim oProjectFile As FileLocations
 Set oProjectFile = ThisApplication.FileLocations

 Dim strRepositoryName As String
 Dim eLocType As LocationTypeEnum
 Call oProjectFile.FindInLocations(oDoc.Fullfilename, strRepositoryName, eLocType)

 If eLocType = kWorkspaceLocation Then
 Dim strWorkspace As String
 strWorkspace = oProjectFile.Workspace

 MsgBox "Part is in Workspace:" & " Path=" & strWorkspace
 End If

 If eLocType = kLibraryLocation Then

 ' Get the list of library paths.
 Dim strLibraryNames() As String
 Dim strLibraryPaths() As String
 Dim iNumLibraries As Long

 Call oProjectFile.Libraries(iNumLibraries, strLibraryNames, strLibraryPaths)
 If iNumLibraries > 0 Then
 ' Iterate through the list of Libraries. The array is filled
 ' zero based, so the iteration begins a zero.
 For i = 0 To iNumLibraries - 1
 If strRepositoryName = strLibraryNames(i) Then
 MsgBox "Part is in Library:" & " Name=" & strLibraryNames(i) & ", Path=" & strLibraryPaths(i)
 End If
 Next
 End If

 End If

 End Sub

[Anonymous]

Sub Create_Start_Part()
    Dim Doc As Document
    Dim DocFullfileName As String
    Dim DocFilePath As String
    Dim DocType As DocumentTypeEnum
    Dim obj As Object
    Dim ObjFullfileName As String
    Dim eLocType As LocationTypeEnum
    Dim ChildDoc As Document
    Dim CompFileNameOnly As String
    Dim index As Integer
    
    'Get the active document.
    Set Doc = ThisApplication.ActiveDocument
    
    On Error Resume Next '-----------Skip Error
    DocFullfileName = Doc.Fullfilename
    
    'get the location of the last backslash
    index = InStrRev(DocFullfileName, "\")
    DocFilePath = Left(DocFullfileName, index - 1)
        
    'Check if any file is open. if nothing is open exit macro.
    Set oDef = Doc.ComponentDefinition
    If Err Then
        'Unable to get the Parameters object, so exit.
        MsgBox "Unable to access the parameters. An assembly must be Open."
        Exit Sub
    End If
    On Error GoTo 0 '-----------Error Reset
    'Get Document Type and check wheter it is a part or assembly file, else exit Macro
    DocType = Doc.DocumentType
    If DocType = kAssemblyDocumentObject Then
        'Pass
    Else
        MsgBox "File Type Not Compatible. Please Use an Assembly File"
        Exit Sub
    End If
    'check whether something is selected in the assembly
    On Error Resume Next '----------Skip Error
    Set obj = Doc.SelectSet.Item(1)
    If Err Then
        On Error GoTo 0 '----------Error Reset
        MsgBox "Select a Part or Sub-Assembly"
        Exit Sub
    Else
        If (TypeOf obj Is ComponentOccurrence) Then
            Dim occ As ComponentOccurrence
            Set occ = obj
            'ObjFullfileName = occ.Definition.Document.Fullfilename
        Else: Exit Sub ' this never executes. i think so.
        End If
        
        'Set ChildDoc = ThisApplication.Documents.Open(ObjFullfileName, True)
        'ChildDoc.Activate
        Set ChildDoc = occ.Definition.Document ' this works without opening the document
        'For iParts Childdoc should be Factory and not Factory Member so we go a step deeper
        If occ.IsiPartMember = True Then
            Set ChildDoc = ChildDoc.ReferencedDocumentDescriptors(1).ReferencedDocument
        Else: End If ' in all other cases such as i-Assembly and Normal Part and Assembly childdoc should be member only i.e occ.Definition.Document
        
        Dim NewChild As Document
        Dim NewChildPath As String
        
        NewChildPath = SaveCopyFileDialog(ChildDoc, DocFilePath)
        Set NewChild = ThisApplication.Documents.Open(NewChildPath, True)
        
        If NewChildPath <> "" Then 'in Case User Clicked Cancel in Save File Dialog.
            If occ.IsiPartMember Then
                'Code to Convert Part Factory to Normal, Make Current used Variant as active Factory member and delete Factory
               ConvertFactoryToPart NewChild, Left(occ.Name, InStrRev(occ.Name, ":") - 1)
               NewChild.Save
            Else
                If occ.IsiAssemblyMember Then
                    ' code to break Table link here
                    NewChild.ComponentDefinition.iAssemblyMember.BreakLinkToFactory
                    NewChild.Save
                End If
            End If
                Call occ.Replace(NewChildPath, False)
                'ChildDoc.Close ' in case ChildDoc is open
                NewChild.Activate
                'Doc.Update
        Else: End If
    End If
    'On Error GoTo 0
End Sub

Public Function SaveCopyFileDialog(ByRef fChildDoc As Document, ByRef fDocFilePath As String) As String
    Dim DefChildDocName, test As String ' test variable used for reference only for showing another way to het DefChilddocName
    
    ' Set a reference to the FileLocations object.
    'Dim oFileLocations As FileLocations
    'Set oFileLocations = ThisApplication.FileLocations

    'Dim sPath As String
    'Debug.Print "Workspace: " & oFileLocations.Workspace ' Display the workspace.
    'sPath = oFileLocations.Workspace '***
 
    'Create a new FileDialog object.
    Dim oFileDlg As FileDialog
    Call ThisApplication.CreateFileDialog(oFileDlg)
    
    'Set the title for the dialog.
    oFileDlg.DialogTitle = "Save File As"

    'Define the filter to select part and assembly files or any file.
    'oFileDlg.Filter = "Assy (*.iam)|*.iam|Part(*.ipt)|*.ipt" since Filter index is failing in case of Save Dialog we disabled this
    Select Case fChildDoc.DocumentType
        Case kAssemblyDocumentObject:   oFileDlg.Filter = "Assy (*.iam)|*.iam"
        Case kPartDocumentObject:       oFileDlg.Filter = "Part(*.ipt)|*.ipt"
        Case Else
            MsgBox " Not as Part or Assembly File"
            Exit Function
    End Select
    
    'Define the part and assembly files filter to be the default filter.
    Select Case fChildDoc.DocumentType
        Case kAssemblyDocumentObject:   oFileDlg.FilterIndex = 1
        Case kPartDocumentObject:       oFileDlg.FilterIndex = 1 '2
        Case Else
            MsgBox " Not as Part or Assembly File"
            Exit Function
    End Select
    
    'Set the initial directory that will be displayed in the dialog.
    DefChildDocName = Right(fChildDoc.Fullfilename, Len(fChildDoc.Fullfilename) - InStrRev(fChildDoc.Fullfilename, "\"))
    test = Mid(fChildDoc.Fullfilename, InStrRev(fChildDoc.Fullfilename, "\") + 1, InStrRev(fChildDoc.Fullfilename, ".") - InStrRev(fChildDoc.Fullfilename, "\") - 1)
    oFileDlg.InitialDirectory = fDocFilePath 'this does not work for save dialog but works for open dialog ***'sPath 'in case you want workspace
    oFileDlg.filename = fDocFilePath & "\" & DefChildDocName 'this works for save dialog ***'sPath 'in case you want workspace
    
    ' Set the flag so an error will be raised if the user clicks the Cancel button.
    oFileDlg.CancelError = True

    ' Show the open dialog.  The same procedure is also used for the Save dialog.
    ' The commented code can be used for the Save dialog.
    On Error Resume Next
    'oFileDlg.ShowOpen
    oFileDlg.ShowSave
    
    ' If an error was raised, the user clicked cancel, otherwise display the filename.
    If Err Then
        MsgBox "User cancelled out of dialog"
    ElseIf oFileDlg.filename <> "" Then
        Call fChildDoc.SaveAs(oFileDlg.filename, True)
        SaveCopyFileDialog = oFileDlg.filename
        'MsgBox "ChildDoc is " & oFileDlg.filename
    End If
   
End Function

Public Sub ConvertFactoryToPart(ByRef sDoc As PartDocument, ChildName As String)
    Dim oFactory As iPartFactory
    Dim RowCount As Integer
    ' Get the Excel spreadsheet from the factory.  You'll need to use the Tools->References command to reference the
    ' "Microsoft Excel Object Library" to have access to the Excel objects.
    Dim oSheet As Excel.WorkSheet
    Dim i As Long
    Dim oFileName As String

    Set oFactory = sDoc.ComponentDefinition.iPartFactory
    RowCount = oFactory.TableRows.Count
    Set oSheet = oFactory.ExcelWorkSheet ' its easier to make changes Excel Sheet
    For i = 1 To RowCount
        oFileName = GetFileNameFromRow(oSheet, i)
        If oFileName = ChildName Then
            oFileName = oFileName + ".ipt"
            'Change Default Member
            ChangeDefaultFactoryMember oSheet, i
            sDoc.Update
            'Delete Factory
            sDoc.ComponentDefinition.iPartFactory.Delete
            GoTo Escape 'Exit For
        Else
        End If
    Next i
    'if logic finishes the loop then member is missing in factory. not sure where to put this message. to be decided later
    MsgBox "Member Component not Present in Factory"
Escape:
End Sub

Private Function GetFileNameFromRow(fSheet As Excel.WorkSheet, index) As String
    Dim oCell
    Dim oRange As Range
    Dim lColumn As Long
    oCell = fSheet.Cells(1, 1)
    Set oRange = fSheet.Rows.Find("<filename></filename>", , , , , xlNext, False)
    lColumn = oRange.Column
    oCell = fSheet.Cells(index + 1, lColumn)
    Debug.Print oCell
    GetFileNameFromRow = CStr(oCell)
End Function

'The Excel Sheet closes here. its awkward being defined in ConvertFactoryTopart subroutine but closing in this subroutine but this is it.
'Bottom Part can be shifted to make it not awkward but i am too lazy to do it now.
Private Sub ChangeDefaultFactoryMember(sSheet As Excel.WorkSheet, index As Long)
    Dim oCell
    oCell = sSheet.Cells(1, 1)
    'Split the default cell's string every time to replace the row number
    Dim aDefCell()
    aDefCell = SplitDefaultString(CStr(oCell))
    oCell = aDefCell(0) + CStr(index) + aDefCell(1)
    sSheet.Cells(1, 1) = oCell
    ' Save the changes and quit Excel.
    Dim oWorkBook As Excel.Workbook
    Set oWorkBook = sSheet.Parent
    oWorkBook.Save
    SendKeys "Y"
    oWorkBook.Close
    Set oWorkBook = Nothing
    Set sSheet = Nothing
End Sub

Private Function SplitDefaultString(sDefStr As String) As Variant
  Dim aDefString(), pos1 As Integer, pos2 As Integer
  ReDim aDefString(1)
  pos1 = InStr(1, sDefStr, "<defaultRow>", vbBinaryCompare)
  pos2 = InStr(pos1 + 9, sDefStr, "</defaultRow>", vbBinaryCompare)
  aDefString(0) = Left(sDefStr, pos1 + 11)
  aDefString(1) = Right(sDefStr, Len(sDefStr) - pos2 + 1)
  SplitDefaultString = aDefString
End Function

Ok Just Posting my new code here.

We needed to Make Custom parts/Assemblies from i-Parts/i-Assemblies so we needed something to Create Duplicate parts/Assemblies which would not belong to a Factory. This Code works good for Now

But Still i Cant Figure out

1) FileDialog Filter Index wont Work

2) File Dialog Initial Directory wont Work.

Any Help is Appreciated.

Thanks and Regards,

Jiten

[Owner2229]

Hi, try this. I have shortened your code a bit (still a lot of work to do there), so it is a bit easier to read. Commands "Let" and "Set" are no longer supported in newer versions of Inventor (from 2014 I think), so I cleaned them, so your code could work in these versions to. You can add your comments back if you want to.

Sub Main()
    Dim oDoc As Document = ThisApplication.ActiveDocument
    If Not oDoc.DocumentType = kAssemblyDocumentObject Then
        MsgBox "File Type Is Not Compatible. Please Use an Assembly File"
        Exit Sub
    End If
	Dim DocFilePath As String = ThisDoc.Path
    On Error Resume Next
    Try
	Dim obj As Object = oDoc.SelectSet.Item(1)
    Catch
	MsgBox "Select a Part or an Sub-Assembly"
	Exit Sub
    End Try
    If (TypeOf obj Is ComponentOccurrence) Then
        Dim occ As ComponentOccurrence = obj
    Else
	Exit Sub
    End If
    Dim ChildDoc As Document = occ.Definition.Document
    If occ.IsiPartMember = True Then
        ChildDoc = ChildDoc.ReferencedDocumentDescriptors(1).ReferencedDocument
    End If
    Dim NewChildPath As String = SaveCopyFileDialog(ChildDoc, DocFilePath)
    Dim NewChild As Document = ThisApplication.Documents.Open(NewChildPath, True)
    If NewChildPath <> "" Then
        If occ.IsiPartMember Then
            Call ConvertFactoryToPart(NewChild, Left(occ.Name, InStrRev(occ.Name, ":") - 1))
            NewChild.Save
        Else
            If occ.IsiAssemblyMember Then
                NewChild.ComponentDefinition.iAssemblyMember.BreakLinkToFactory
                NewChild.Save
            End If
        End If
        Call occ.Replace(NewChildPath, False)
        NewChild.Activate
    End If
End Sub

Public Function SaveCopyFileDialog(ByRef fChildDoc As Document, ByRef fDocFilePath As String) As String
    Dim DefChildDocName As String
    Dim oFileDlg As FileDialog
    Call ThisApplication.CreateFileDialog(oFileDlg)
    oFileDlg.DialogTitle = "Save File As"
    Select Case fChildDoc.DocumentType
        Case kAssemblyDocumentObject
            oFileDlg.Filter = "Assy (*.iam)|*.iam"
	    oFileDlg.FilterIndex = 1
        Case kPartDocumentObject
            oFileDlg.Filter = "Part(*.ipt)|*.ipt"
	    oFileDlg.FilterIndex = 2
        Case Else
            MsgBox " Not a Part or Assembly File"
            Exit Function
    End Select
    DefChildDocName = Right(fChildDoc.Fullfilename, Len(fChildDoc.Fullfilename) - InStrRev(fChildDoc.Fullfilename, "\"))
    oFileDlg.InitialDirectory = fDocFilePath
    oFileDlg.filename = fDocFilePath & "\" & DefChildDocName
    oFileDlg.CancelError = True
    On Error Resume Next
    oFileDlg.ShowSave
    If Err Then
        MsgBox "User cancelled out of dialog"
    ElseIf oFileDlg.filename <> "" Then
        Call fChildDoc.SaveAs(oFileDlg.filename, True)
        SaveCopyFileDialog = oFileDlg.filename
    End If
End Function

Sub ConvertFactoryToPart(ByRef sDoc As PartDocument, ChildName As String)  
    Dim i As Long
    Dim oFileName As String
    Dim oFactory As iPartFactory = sDoc.ComponentDefinition.iPartFactory
    Dim RowCount As Integer = oFactory.TableRows.Count
    Dim oSheet As Excel.WorkSheet = oFactory.ExcelWorkSheet
    For i = 1 To RowCount
        oFileName = GetFileNameFromRow(oSheet, i)
        If oFileName = ChildName Then
            oFileName = oFileName + ".ipt"
            Call ChangeDefaultFactoryMember(oSheet, i)
            sDoc.Update
            sDoc.ComponentDefinition.iPartFactory.Delete
            GoTo Escape 'Exit For
        Else
        End If
    Next i
    'if logic finishes the loop then member is missing in factory. not sure where to put this message. to be decided later
    MsgBox "Member Component not Present in Factory"
End Sub

Private Function GetFileNameFromRow(fSheet As Excel.WorkSheet, index) As String
    Dim oCell
    oCell = fSheet.Cells(1, 1)
    Dim oRange As Range = fSheet.Rows.Find("<filename></filename>", , , , , xlNext, False) 'What? An Orange in your rule? I wouldn't mess with fruit here.
    Dim lColumn As Long = oRange.Column
    oCell = fSheet.Cells(index + 1, lColumn)
    Debug.Print oCell
    GetFileNameFromRow = CStr(oCell)
End Function

Sub ChangeDefaultFactoryMember(sSheet As Excel.WorkSheet, index As Long)
    Dim oCell
    oCell = sSheet.Cells(1, 1)
    Dim aDefCell()
    aDefCell = SplitDefaultString(CStr(oCell))
    oCell = aDefCell(0) + CStr(index) + aDefCell(1)
    sSheet.Cells(1, 1) = oCell
    Dim oWorkBook As Excel.Workbook
    oWorkBook = sSheet.Parent
    oWorkBook.Save
    SendKeys "Y"
    oWorkBook.Close
    oWorkBook = Nothing
    sSheet = Nothing
End Sub

Private Function SplitDefaultString(sDefStr As String) As Variant
    Dim aDefString(), pos1 As Integer, pos2 As Integer
    ReDim aDefString(1)
    pos1 = InStr(1, sDefStr, "<defaultRow>", vbBinaryCompare)
    pos2 = InStr(pos1 + 9, sDefStr, "</defaultRow>", vbBinaryCompare)
    aDefString(0) = Left(sDefStr, pos1 + 11)
    aDefString(1) = Right(sDefStr, Len(sDefStr) - pos2 + 1)
    SplitDefaultString = aDefString
End Function

[Anonymous]

Sub Create_Start_Part()
    Dim Doc As Document
    Dim DocFullfileName As String
    Dim DocFilePath As String
    Dim DocType As DocumentTypeEnum
    Dim oDef As ComponentDefinition
    Dim obj As Object
    Dim ObjFullfileName As String
    Dim eLocType As LocationTypeEnum
    Dim ChildDoc As Document
    Dim CompFileNameOnly As String
    Dim index As Integer
    Dim NewChildName As String ' Added on 02/08/2016 as Part Number was not updated on New Child Save
    Dim NewChildPropset As PropertySet ' Added on 02/08/2016 as Part Number was not updated on New Child Save
    Dim NewChildPartNumberProp As Property ' Added on 02/08/2016 as Part Number was not updated on New Child Save
    'Get the active document.
    Set Doc = ThisApplication.ActiveDocument
    '------------------------Testing For Errors----------------------------
    On Error Resume Next '-----------Skip Error
    DocFullfileName = Doc.FullFileName
    'Check if any file is open
    'Set oDef = Doc.ComponentDefinition
    If Err Then
        'Unable to find any file open, so exit.
        MsgBox "Unable to access any File. An Assembly must be Open to process this command." '& ":" & Err.Description
        Exit Sub
    End If
    'Get Document Type and check whether it is an assembly file, else exit Macro
    DocType = Doc.DocumentType
    If DocType <> kAssemblyDocumentObject Then
        MsgBox "File Type Not Compatible. This command works only on Assembly File."
        Exit Sub
    End If
    'Check if the Assembly File is saved. if not saved exit macro.
    If DocFullfileName = "" Then
        'Unable to get the Parameters object, so exit.
        MsgBox "Unable to access this File on Disk. This assembly needs to be Saved."
        Exit Sub
    End If
    'check whether something is selected in the assembly
    Set obj = Doc.SelectSet.Item(1)
    If Err Then
        MsgBox "Nothing is Selected. Select a Child Part or Child Sub-Assembly" '& ":" & Err.Description
        Exit Sub
    End If
    'Check if selected thing is Part or a Assembly
    If (TypeOf obj Is ComponentOccurrence) Then
        Dim occ As ComponentOccurrence
        Set occ = obj
        'ObjFullfileName = occ.Definition.Document.Fullfilename
    Else
        MsgBox "Selection not Valid. Select Child Part or Child Sub-Assembly."
        Exit Sub ' this never executes. i think so. so no msgbox is assigned.
    End If
    On Error GoTo 0 '----------Error Reset
    'MsgBox Err.Number ' Catch Errors Here
'----------------------------XXXXXXXXXXXXXXXXXXXXXXXXXXXXX------------------------------
'-------------------------------whole process begins here-------------------------------
        index = InStrRev(DocFullfileName, "\") 'get the location of the last backslash
        DocFilePath = Left(DocFullfileName, index - 1) 'Gets String From Left Side total of index-1 characters. -1 for deleting last \.
        
        'Set ChildDoc = ThisApplication.Documents.Open(ObjFullfileName, True)
        'ChildDoc.Activate
        Set ChildDoc = occ.Definition.Document ' this works without opening the document
        'For iParts Childdoc should be Factory and not Factory Member so we go a step deeper
        If occ.IsiPartMember = True Then
            Set ChildDoc = ChildDoc.ReferencedDocumentDescriptors(1).ReferencedDocument
        Else: End If ' in all other cases such as i-Assembly and Normal Part and Assembly childdoc should be member only i.e occ.Definition.Document

        Dim NewChild As Document
        Dim NewChildPath As String

        NewChildPath = SaveCopyFileDialog(ChildDoc, DocFilePath)
        If NewChildPath <> "" Then 'in Case User Clicked Cancel in Save File Dialog NewchildPath will be "".
            Set NewChild = ThisApplication.Documents.Open(NewChildPath, False)
            If occ.IsiPartMember Then
                'Code to Convert Part Factory to Normal, Make Current used Variant as active Factory member and delete Factory
                ConvertFactoryToPart NewChild, Left(occ.Name, InStrRev(occ.Name, ":") - 1)
                'NewChild.Save
            Else
                If occ.IsiAssemblyMember Then
                    ' code to break Table link here
                    NewChild.ComponentDefinition.iAssemblyMember.BreakLinkToFactory
                    'NewChild.Save
                End If
            End If
            'Change Partnumber Property
            NewChildName = Mid(NewChild.FullFileName, InStrRev(NewChild.FullFileName, "\") + 1, InStrRev(NewChild.FullFileName, ".") - InStrRev(NewChild.FullFileName, "\") - 1) ' Added on 02/08/2016 as Part Number was not updated on New Child Save
            Set NewChildPropset = NewChild.PropertySets.Item("Design Tracking Properties") ' Added on 02/08/2016 as Part Number was not updated on New Child Save
            Set NewChildPartNumberProp = NewChildPropset.Item("Part Number") ' Added on 02/08/2016 as Part Number was not updated on New Child Save
            NewChildPartNumberProp.Value = NewChildName ' Added on 02/08/2016 as Part Number was not updated on New Child Save
            
            NewChild.Save
               
            Call occ.Replace(NewChildPath, False)
            'ChildDoc.Close ' in case ChildDoc is open
            'NewChild.Update ' Inventor doesnot recognise Newchild as not a factory member but did not help.
            NewChild.Close ' Inventor doesnot recognise Newchild as not a factory member
            Doc.Update
            Set NewChild = ThisApplication.Documents.Open(NewChildPath, True)
        Else: End If
End Sub

Public Function SaveCopyFileDialog(ByRef fChildDoc As Document, ByRef fDocFilePath As String) As String
    Dim DefChildDocName, test As String ' test variable used for reference only for showing another way to het DefChilddocName
    
    'Set a reference to the FileLocations object.
    'Dim oFileLocations As FileLocations
    'Set oFileLocations = ThisApplication.FileLocations

    'Dim sPath As String
    'Debug.Print "Workspace: " & oFileLocations.Workspace ' Display the workspace.
    'sPath = oFileLocations.Workspace '***
 
    'Create a new FileDialog object.
    Dim oFileDlg As FileDialog
    Call ThisApplication.CreateFileDialog(oFileDlg)
    'Set the title for the dialog.
    oFileDlg.DialogTitle = "Save File As"
    'Define the filter to select part and assembly files or any file.
    'oFileDlg.Filter = "Assy (*.iam)|*.iam|Part(*.ipt)|*.ipt" since Filter index is failing in case of Save Dialog we disabled this
    Select Case fChildDoc.DocumentType
        Case kAssemblyDocumentObject:   oFileDlg.Filter = "Assy (*.iam)|*.iam"
        Case kPartDocumentObject:       oFileDlg.Filter = "Part(*.ipt)|*.ipt"
        Case Else
            MsgBox " Not as Part or Assembly File"
            Exit Function
    End Select
    'Define the part and assembly files filter to be the default filter.
    Select Case fChildDoc.DocumentType
        Case kAssemblyDocumentObject:   oFileDlg.FilterIndex = 1
        Case kPartDocumentObject:       oFileDlg.FilterIndex = 1 '2
        Case Else
            MsgBox "Selection Not a Part or Assembly File."
            Exit Function
    End Select
    'Set the initial directory that will be displayed in the dialog.
    DefChildDocName = Right(fChildDoc.FullFileName, Len(fChildDoc.FullFileName) - InStrRev(fChildDoc.FullFileName, "\"))
    test = Mid(fChildDoc.FullFileName, InStrRev(fChildDoc.FullFileName, "\") + 1, InStrRev(fChildDoc.FullFileName, ".") - InStrRev(fChildDoc.FullFileName, "\") - 1)
    oFileDlg.InitialDirectory = fDocFilePath 'this does not work for save dialog but works for open dialog ***'sPath 'in case you want workspace
    oFileDlg.FileName = fDocFilePath & "\" & DefChildDocName 'this works for save dialog ***'sPath 'in case you want workspace
    'Set the flag so an error will be raised if the user clicks the Cancel button.
    oFileDlg.CancelError = True
    'Show the open dialog.  The same procedure is also used for the Save dialog.
    'The commented code can be used for the Save dialog.
    On Error Resume Next
    'oFileDlg.ShowOpen
    oFileDlg.ShowSave
    ' If an error was raised, the user clicked cancel, otherwise display the filename.
    If Err Then
        MsgBox "User cancelled out of dialog."
        Exit Function
    ElseIf oFileDlg.FileName <> "" Then
        Call fChildDoc.SaveAs(oFileDlg.FileName, True) ' Saving file to new document Name
        SaveCopyFileDialog = oFileDlg.FileName
        'MsgBox "ChildDoc is " & oFileDlg.filename
    End If
End Function

Public Sub ConvertFactoryToPart(ByRef sDoc As PartDocument, ChildName As String)
    Dim oFactory As iPartFactory
    Dim RowCount As Integer
    ' Get the Excel spreadsheet from the factory.  You'll need to use the Tools->References command to reference the
    ' "Microsoft Excel Object Library" to have access to the Excel objects.
    Dim oSheet As Excel.WorkSheet
    Dim i As Long
    Dim oFileName As String

    Set oFactory = sDoc.ComponentDefinition.iPartFactory
    RowCount = oFactory.TableRows.Count
    Set oSheet = oFactory.ExcelWorkSheet ' its easier to make changes Excel Sheet
    For i = 1 To RowCount
        oFileName = GetFileNameFromRow(oSheet, i)
        If oFileName = ChildName Then
            oFileName = oFileName + ".ipt"
            'Change Default Member
            ChangeDefaultFactoryMember oSheet, i
            sDoc.Update
            'Delete Factory
            sDoc.ComponentDefinition.iPartFactory.Delete
            GoTo Escape 'Exit For
        Else
        End If
    Next i
    'if logic finishes the loop then member is missing in factory. not sure where to put this message. to be decided later
    MsgBox "Member Component not Present in Factory"
Escape:
End Sub

Private Function GetFileNameFromRow(fSheet As Excel.WorkSheet, index) As String
    Dim oCell
    Dim oRange As Range
    Dim lColumn As Long
    oCell = fSheet.Cells(1, 1)
    Set oRange = fSheet.Rows.Find("<filename></filename>", , , , , xlNext, False)
    lColumn = oRange.Column
    oCell = fSheet.Cells(index + 1, lColumn)
    Debug.Print oCell
    GetFileNameFromRow = CStr(oCell)
End Function

'The Excel Sheet closes here. its awkward being defined in ConvertFactoryTopart subroutine but closing in this subroutine but this is it.
'Bottom Part can be shifted to make it not awkward but i am too lazy to do it now.
Private Sub ChangeDefaultFactoryMember(sSheet As Excel.WorkSheet, index As Long)
    Dim oCell
    oCell = sSheet.Cells(1, 1)
    'Split the default cell's string every time to replace the row number
    Dim aDefCell()
    aDefCell = SplitDefaultString(CStr(oCell))
    oCell = aDefCell(0) + CStr(index) + aDefCell(1)
    sSheet.Cells(1, 1) = oCell
    ' Save the changes and quit Excel.
    Dim oWorkBook As Excel.Workbook
    Set oWorkBook = sSheet.Parent
    oWorkBook.Save
    SendKeys "Y"
    oWorkBook.Close
    Set oWorkBook = Nothing
    Set sSheet = Nothing
End Sub

Private Function SplitDefaultString(sDefStr As String) As Variant
  Dim aDefString(), pos1 As Integer, pos2 As Integer
  ReDim aDefString(1)
  pos1 = InStr(1, sDefStr, "<defaultRow>", vbBinaryCompare)
  pos2 = InStr(pos1 + 9, sDefStr, "</defaultRow>", vbBinaryCompare)
  aDefString(0) = Left(sDefStr, pos1 + 11)
  aDefString(1) = Right(sDefStr, Len(sDefStr) - pos2 + 1)
  SplitDefaultString = aDefString
End Function

Hi,

A little update. the previous code did not update Part Number property. So posting the new one which does.

Hi

Owner2229,

Thanks for that work there.I am still a lazy fellow to keep my work clean (;-)). I am now using 2016 but my code still works.

Thanks

Jit

en

[Owner2229]

Hi, there's old wisdom saying: Code like the person who will read it has anger management issues and knows where you live 😉

The first thing to do is clean the commented, unussed statements. It's fine to keep them in as long as you're testing your code, but delete them as soon as you know that the current solution is working. If you want to keep them for later to use, then copy them somewhere else (in an .txt or something).