Sub Main() 'Declarations Dim oDoc as Document Dim oPartDoc as PartDocument Dim oPartCompDef as PartComponentDefinition Dim oParams as Parameters Dim oUserParams As UserParameters Dim oBody As SurfaceBody Dim strBName As String Dim strSubID As String Dim strSubSubID As String Dim strPartID As String Dim oSet As HighlightSet Dim oSelected As ObjectCollection Dim oMatrix As Matrix Dim strWorkpath As String Dim strFileName As String Dim strPath as string Dim m_inventorApp As Inventor.InventorServer = ThisApplication Dim oPartDocFinal As PartDocument Dim oFinalCompDef as PartComponentDefinition Dim oTargetParams as UserParameters Dim oTargetParameter as Parameter Dim oBodyParamL as Parameter Dim oBodyParamW as Parameter Dim oBodyParamTh as Parameter Dim oBodyParam as Parameter Dim aProperties as New ArrayList Dim aPropAbbr as New ArrayList Dim aPropV(3) Dim lngScale as Long Dim lngScaleF as Long Dim lngLength as Long Dim lngWidth as Long Dim lngThickness as Long Dim lngDiameter as Long Dim oDerivedPrtDef As DerivedPartDefinition Dim oDerivedEntity as DerivedPartEntity 'End Declarations 'On Error Resume Next aProperties.Add ("Length") aProperties.Add ("Width") aProperties.Add ("PlateTh") aProperties.Add ("Diameter") aPropAbbr.Add ("L") aPropAbbr.Add ("W") aPropAbbr.Add ("Th") aPropAbbr.ADD ("D") For a = 0 to 2 'msgBox (aProperties(a)) Next a oDoc = ThisDoc.Document oRedColor = oDoc.Assets("Red") oPlateColor = oDoc.Assets("Plate") strWorkpath = ThisDoc.Path 'oFolder = strWorkpath strPath = strWorkpath 'msgBox (strPath) 'Check for the Parts folder and create it if it does not exist 'If Not System.IO.Directory.Exists(oFolder) Then 'System.IO.Directory.CreateDirectory(oFolder) 'End If If oDoc.DocumentType = kPartDocumentObject Then oPartDoc = oDoc oPartCompDef = oPartDoc.ComponentDefinition oParams = oPartCompDef.Parameters oUserParams=oPartCompDef.Parameters.UserParameters 'oParameter=oUserParams.Item("PlateTh") 'oPartDoc.SaveAs(strWorkPath & "\" & "Test.ipt",True) i = oPartDoc.ComponentDefinition.SurfaceBodies.Count oUserParams=oPartCompDef.Parameters.UserParameters 'oParameter = oUserParams.Item("PlateTh") lngScale =1.00 Select Case strUnits Case "in" lngScale = 2.54 Case "mm" lngScale = 10.00 Case "mm" lngScale = 0.01 End Select 'msgBox(lngThickness & "-" & strUnits) For x = 1 to i oBody = oPartDoc.ComponentDefinition.SurfaceBodies.Item (x) If oBody.IsSolid Then strBName = oBody.Name strDName = strBName & "Description" oBodyParamDescription = oUserParams.Item(strDName) strBDescription = oBodyParamDescription.Value 'If InStr(strBDescription, "SHAFT") <> 0 Then strFileName = "PT " & strBName & ".ipt" 'msgBox (strBName) 'define body properties For y = 0 to 3 strPName =strBName & aPropAbbr(y) 'msgBox (strPName) oBodyParam = oParams.Item (strPName) strUnits = oBodyParam.Units 'lngScale =1.00 Select Case strUnits Case "in" lngScale = 2.5400 Case "mm" lngScale = 10.0000 Case "mm" lngScale = 0.0100 End Select 'msgBox(oBodyParam.Value) aPropV(y)= oBodyParam.Value 'msgBox (strPName & "-" & strUnits & " / " & lngScale & VbCrLf & aPropV(y) & " = " & oBodyParam.Value/lngScale ) aPropV(y)= oBodyParam.Value/2.54 'msgBox (strPName & " - " & aPropV(y)) Next y lngLength=aPropV(0) lngWidth=aPropV(1) lngThickness=aPropV(2) lngDiameter=aPropV(3) 'create derived part oPartDocFinal = CType(ThisApplication.Documents.Add(DocumentTypeEnum.kPartDocumentObject, , False),PartDocument) oFinalCompDef = oPartDocFinal.ComponentDefinition oPartDocFinal.UnitsOfMeasure.LengthUnits = UnitsTypeEnum.kInchLengthUnits oDerivedPrtDef = oFinalCompDef.ReferenceComponents.DerivedPartComponents.CreateDefinition(oPartDoc.FullDocumentName) 'oDerivedPrtDef.ExcludeAll 'oDerivedPrtDef.IncludeAllSolids=kDerivedIncludeAll'kDerivedIndividualDefined oDerivedPrtDef.IncludeAllParameters=True For each oDerivedEntity in oDerivedPrtDef.Solids strEName = oDerivedEntity.ReferencedEntity.Name msgBox (strEName) If strEName <> strBName Then oDerivedEntity.IncludeEntity = False End If Next 'oDerivedPrtDef.Solids.Add(oBody) oFinalCompDef.ReferenceComponents.DerivedPartComponents.Add(oDerivedPrtDef) For q = 0 to 3 oTargetParams = oFinalCompDef.Parameters.UserParameters oTargetParameter = oTargetParams.AddByValue(aProperties(q),1,UnitsTypeEnum.kInchLengthUnits) strPExpression = strBName & aPropAbbr(q) oTargetParameter.Expression = strPExpression Next q 'oPartDocFinal.ComponentDefinition.Features.NonParametricBaseFeatures.Add(oBody,oMatrix) oPartDocFinal.SaveAs(strWorkPath & "\" & "PT_" & strBName & ".ipt", True) 'oTargetParameter.Value = 1 End If Next x 'strWorkpath = oPartDoc.Path 'strPath = strWorkPath & "/Parts" REM For Each oBody In oPartDoc.ComponentDefinition.SurfaceBodies REM If oBody.IsSolid Then REM 'oBody.Appearance = oRedColor REM strBName = oBody.Name REM 'MsgBox (strBName) REM strFileName = "PT " & strBName & ".ipt" REM strFullPath = strPath & "\" & strFileName REM MsgBox (strFullPath) REM 'msgBox("1") REM 'oMatrix = m_inventorApp.TransientGeometry.CreateMatrix() REM 'msgBox("2") REM oPartDocFinal = CType(ThisApplication.Documents.Add(DocumentTypeEnum.kPartDocumentObject, , False),PartDocument) REM 'msgBox("3") REM 'oPartDocFinal.UnitsOfMeasure.LengthUnits = UnitsTypeEnum.kInchLengthUnits REM 'msgBox("4") REM 'oBody.Appearance = oPlateColor REM 'oPartDocFinal.ComponentDefinition.Features.NonParametricBaseFeatures.Add(oBody,oMatrix) REM msgBox("5") REM 'msgBox(strPath & "\" & strFileName & VbCrLf & strFullPath) REM Call oPartDocFinal.SaveAs(strWorkPath & "\" & strFileName,False) REM msgBox("6") REM End If REM Next End If End Sub REM Function ParameterUnitsConvert(strUnitString as String)as Long REM lngScale =1.00 REM Select Case strUnitString REM Case "in" REM lngScale = 2.54 REM Case "mm" REM lngScale = 10.00 REM Case "mm" REM lngScale = 0.01 REM End Select REM ParameterUnitsConvert = lngScaleF REM msgBox (lngScaleF) REM End Function