Hi Acheson
At the end of my code.
A new document opens indeed. This document has the same name but with some extra info at the back.
Here the complete rule:
Sub main
If TypeOf ThisDoc.Document Is AssemblyDocument Then
Dim oAssDoc As AssemblyDocument = ThisDoc.Document
Dim fso As Object = ThisApplication.FileManager.FileSystemObject
Dim oPartOcc As ComponentOccurrence = ThisApplication.CommandManager.Pick(SelectionFilterEnum.kAssemblyLeafOccurrenceFilter, _
"Select your part...(Press ESC to cancel)")
If oPartOcc Is Nothing Then Exit Sub
If TypeOf oPartOcc.Definition Is PartComponentDefinition Then
Dim oPartDef As PartComponentDefinition = oPartOcc.Definition
Dim oPartDoc As PartDocument = oPartDef.Document
Dim oUseParams As UserParameters = oPartDef.Parameters.UserParameters
Dim sLength As String = InputBox("Enter the length parameter:", "Parameter.", oUseParams.Item("FixedUnit_Length").Expression)
'Clean sLength so only numbers are left over
Dim sLengthCleaned As String
For i As Integer = 0 To sLength.Length - 1
If Char.IsDigit(sLength(i)) Or sLength(i) = "."c Then
sLengthCleaned &= sLength(i)
End If
Next
Dim newLength As Double = Double.Parse(sLengthCleaned)
If Not Double.TryParse(sLengthCleaned, newLength) Then Exit Sub
Dim newCurve As String = GetNewParam(oUseParams, "FixedUnit_Curve", oPartDoc.DisplayName)
If newCurve Is Nothing Then Exit Sub
Dim sPath As String = System.IO.Path.GetDirectoryName(oPartDoc.FullFileName)
Dim sFullName As String = sPath & "\" & System.IO.Path.GetFileNameWithoutExtension(oPartDoc.FullFileName) & " - " & Strings.Mid(newCurve, 2, Strings.Len(newCurve) - 2) & " - L" & newLength & "mm.ipt"
If Not System.IO.File.Exists(sFullName) Then
fso.copyFile(oPartDoc.FullDocumentName, sFullName, True)
oPartOcc.Replace(sFullName, True)
Dim oNewPart As PartDocument = GetNewComponent(oAssDoc, sFullName)
Dim oNewParams As UserParameters = oNewPart.ComponentDefinition.Parameters.UserParameters
If sActLength <> newLength Then ChangeParam(oNewParams, "FixedUnit_Length", newLength)
If sActCurve <> newCurve Then ChangeParam(oNewParams, "FixedUnit_Curve", newCurve)
oNewPart.Save()
Else
oPartOcc.Replace(sFullName, True)
MessageBox.Show("Part Already exist", "Error")
End If
oAssDoc.Update()
currentfilename = ThisDoc.FileName(False)
'filepath same as the current ipt
SetTheFilePathHere = ThisDoc.Path
'Set the new file name
SetTheFilenameHere = currentfilename & " - " & Strings.Mid(newCurve, 2, Strings.Len(newCurve) - 2) & " - L" & newLength & "mm"
'Use the CommandManager object to execute a private event that sets the file name and path.
ThisApplication.CommandManager.PostPrivateEvent(kFileNameEvent, SetTheFilePathHere &"\" & SetTheFilenameHere & ".iam")
'Use the ControlDefinitions object to execute a command that saves the file with the new name and path.
Dim oCtrlDef
oCtrlDef = ThisApplication.CommandManager.ControlDefinitions.Item("AppFileSaveCopyAsCmd")
oCtrlDef.Execute
'Close original file without saving
' Get a reference to a specific assembly
Dim asmDoc As AssemblyDocument = ThisApplication.ActiveDocument
Messagebox.Show(asmDoc.FullFileName)
asmDoc.Close(False)
'Open new file
ThisDoc.Launch(SetTheFilePathHere & "\" & SetTheFilenameHere & ".iam")
Else
MessageBox.Show("Select component is not PartDocyment!", "Error",MessageBoxButtons.OK,MessageBoxIcon.Error)
End If
Else
MessageBox.Show("Active document is not AssemblyDocyment!", "Error",MessageBoxButtons.OK,MessageBoxIcon.Error)
End If
End Sub
Private Function GetNewParam(oUseParams As UserParameters, sNameParam As String, sPartName As String) As String
Dim sListParams As New List(Of String)
Dim sActParam As String
Dim iActParam As Integer
For Each oParam As Inventor.Parameter In oUseParams
If oParam.Name = sNameParam Then
sActParam = oParam.Expression
sListParams.AddRange(oParam.ExpressionList.GetExpressionList())
Exit For
End If
Next
If sActParam IsNot Nothing Then
sListParams.Sort
iActParam = sListParams.IndexOf(sActParam)
If iActParam < 0 Then iActParam = 0
Else
MessageBox.Show("The selected component is missing a parameter: " & sNameParam, "Error!",MessageBoxButtons.OK,MessageBoxIcon.Error)
Return Nothing
End If
Dim newParam As String = InputListBox(sPartName, sListParams, sListParams(iActParam), _
Title := "List parameters.", ListName := "Select " & sNameParam & ":")
If newParam Is Nothing Then Return Nothing
Return newParam
End Function
Private Function ChangeParam(oUseParams As UserParameters, sNameParam As String, newExpr As String)
For Each oParam As Inventor.Parameter In oUseParams
If oParam.Name = sNameParam Then
oParam.Expression = newExpr
End If
Next
End Function
Private Function GetNewComponent(oAssDoc As AssemblyDocument, oNameFile As String) As Document
For Each oRefDoc As Document In oAssDoc.AllReferencedDocuments
If oRefDoc.FullDocumentName = oNameFile Then
Return oRefDoc
End If
Next
Return Nothing
End Function
I've tried moving the rule to close the active document up. Instead of putting it at the end.
This doesn't help which is weird because your message box shows the right filepath and right filename.
Let me know what you think.
BR
Justin
