setting a VBA sketch profiles problem

[Anonymous]

I try to set this sketch as profiles but there has an error. The code as follow.

I appreciate any help! 

Public Sub   OOOO()
Dim oApp As Inventor.Application
Set oApp = ThisApplication

Dim oPartDoc As PartDocument
Set oPartDoc = ThisApplication.Documents.Add(kPartDocumentObject, _
ThisApplication.FileManager.GetTemplateFile(kPartDocumentObject))

Dim oSketch As PlanarSketch
Set oSketch = oPartDoc.ComponentDefinition.Sketches.Add(oPartDoc.ComponentDefinition.workPlanes.Item(2))
Dim oTG As TransientGeometry
Set oTG = oApp.TransientGeometry
Dim oSkPnts As SketchPoints
Set oSkPnts = oSketch.SketchPoints
Call oSkPnts.Add(oTG.CreatePoint2d(0, 0), False) 'oSkPnts(1) 1
Call oSkPnts.Add(oTG.CreatePoint2d(0, 1.5 * 2.54), False) 'oSkPnts(2)2

Call oSkPnts.Add(oTG.CreatePoint2d(-10 * 2.54, 1.5 * 2.54), False) 'oSkPnts(7)3
Call oSkPnts.Add(oTG.CreatePoint2d(-10 * 2.54, 0), False) 'oSkPnts(8)4

Call oSkPnts.Add(oTG.CreatePoint2d(-0.10608028 * 2.54, 1.5 * 2.54), False) 'oSkPnts(11) right high 5
Call oSkPnts.Add(oTG.CreatePoint2d(-0.1841075 * 2.54, 1.43765652 * 2.54), False) 'oSkPnts(12) right high 6
Call oSkPnts.Add(oTG.CreatePoint2d(-0.10608028 * 2.54, 1.42 * 2.54), False) 'oSkPnts(13) center of right high 7

Call oSkPnts.Add(oTG.CreatePoint2d(-0.42916783 * 2.54, 0.35469256 * 2.54), False) 'oSkPnts(14) right low 8
Call oSkPnts.Add(oTG.CreatePoint2d(-0.66032347 * 2.54, 0.17 * 2.54), False) 'oSkPnts(15) right low 9
Call oSkPnts.Add(oTG.CreatePoint2d(-0.66032347 * 2.54, 0.407 * 2.54), False) 'oSkPnts(16) center of right low 10

Call oSkPnts.Add(oTG.CreatePoint2d(-9.89391972 * 2.54, 1.5 * 2.54), False) 'oSkPnts(17) left high 11
Call oSkPnts.Add(oTG.CreatePoint2d(-9.8158925 * 2.54, 1.43765652 * 2.54), False) 'oSkPnts(18) left high 12
Call oSkPnts.Add(oTG.CreatePoint2d(-9.89391972 * 2.54, 1.42 * 2.54), False) 'oSkPnts(19) center of left high 13

Call oSkPnts.Add(oTG.CreatePoint2d(-9.57083217 * 2.54, 0.35469256 * 2.54), False) 'oSkPnts(20) left high 14
Call oSkPnts.Add(oTG.CreatePoint2d(-9.33967653 * 2.54, 0.17 * 2.54), False) 'oSkPnts(21) left high 15
Call oSkPnts.Add(oTG.CreatePoint2d(-9.33967653 * 2.54, 0.407 * 2.54), False) 'oSkPnts(22) center of left high 16

Dim oLines As SketchLines
Set oLines = oSketch.SketchLines
Dim oLine(1 To 30) As SketchLine
Set oLine(1) = oLines.AddByTwoPoints(oSkPnts(1), oSkPnts(2)) 'Body
Set oLine(2) = oLines.AddByTwoPoints(oSkPnts(2), oSkPnts(5)) 'Body
Set oLine(3) = oLines.AddByTwoPoints(oSkPnts(6), oSkPnts(8)) 'Body
Set oLine(4) = oLines.AddByTwoPoints(oSkPnts(9), oSkPnts(15)) 'Body
Set oLine(5) = oLines.AddByTwoPoints(oSkPnts(14), oSkPnts(12)) 'Body
Set oLine(6) = oLines.AddByTwoPoints(oSkPnts(11), oSkPnts(3)) 'Body
Set oLine(7) = oLines.AddByTwoPoints(oSkPnts(3), oSkPnts(4)) 'Body
Set oLine(8) = oLines.AddByTwoPoints(oSkPnts(4), oSkPnts(1)) 'Body

Dim oArcs As SketchArcs
Set oArcs = oSketch.SketchArcs
Dim oArc(1 To 4)As SketchArc
Set oArc(1) = oArcs.AddByCenterStartEndPoint(oSkPnts(7), oSkPnts(5), oSkPnts(6))
Set oArc(2) = oArcs.AddByCenterStartEndPoint(oSkPnts(10), oSkPnts(9), oSkPnts(8))
Set oArc(3) = oArcs.AddByCenterStartEndPoint(oSkPnts(16), oSkPnts(14), oSkPnts(15))
Set oArc(4) = oArcs.AddByCenterStartEndPoint(oSkPnts(13), oSkPnts(12), oSkPnts(11))

Dim oProfile(1 To 4)As Profile
Set oProfile(1) = oSketch.Profiles.AddForSolid

'Extride for main body
Dim oExtrudeDef As ExtrudeDefinition
Set oExtrudeDef = oPartDoc.ComponentDefinition.Features.ExtrudeFeatures.CreateExtrudeDefinition(oProfile(1), kJoinOperation)
Call oExtrudeDef.SetDistanceExtent(185.574037 * 2.54, kPositiveExtentDirection)
Dim oExtrude As ExtrudeFeature
Set oExtrude = oPartDoc.ComponentDefinition.Features.ExtrudeFeatures.Add(oExtrudeDef)

End Sub

[A.Acheson · Accepted solution]

So I had a look at this out of curiosity. I am not really experienced with creating sketches like this, but I like a challenge. 

The error occurred as there isn't a close loop. Constraints are missing, see image. 

This issue was addressed here .

Why some of the sketch profile was constrained and more wasn't is another question? 

After 58 parts later 😅I have added these 4 lines to close the loop and complete the profile. 

'Added these lines to merge sketch points
Call oLine(3).StartSketchPoint.Merge(oArc(1).EndSketchPoint)
Call oLine(3).EndSketchPoint.Merge(oArc(2).EndSketchPoint)
Call oLine(4).EndSketchPoint.Merge(oArc(3).EndSketchPoint)
Call oLine(6).StartSketchPoint.Merge(oArc(4).EndSketchPoint)

Dim oProfile(1 To 4) As Profile
Set oProfile(1) = oSketch.Profiles.AddForSolid

 Hope that helps

[FINET_Laurent · Accepted solution]

Hi,

This isn't how it's done.. You are creating lines geometry but not constraining them together.

Here is a test iLogic Rule from me where I tested this a while ago.. :

'///////////////////////////////////VARIABLES////////////////////////////////////

Dim oDoc As Document 
oDoc = ThisApplication.ActiveDocument

Dim oPartComp As PartComponentDefinition
oPartComp = oDoc.ComponentDefinition

Dim oPlanarSketch As PlanarSketch

Dim oTG As TransientGeometry
oTG = ThisApplication.TransientGeometry

'////////////////////////////SET DEFAULT UNIT TO MM//////////////////////////////

Dim oMillimeterUnit As UnitsTypeEnum
oMillimeterUnit = UnitsTypeEnum.kMillimeterLengthUnits 

	oDoc.UnitsOfMeasure.LengthUnits = oMillimeterUnit
	
'//////////////////////////////CREATE USER PARAMETERS////////////////////////////

Dim oGap1 As UserParameter = oPartComp.Parameters.UserParameters.AddByExpression("Gap_1","50","mm")

'///////////////////////////////CREATE SKETCH////////////////////////////////////

oPlanarSketch = oPartComp.Sketches.Add(oPartComp.WorkPlanes.Item(3))
oPlanarSketch.Name = "Sketch 1"

oPlanarSketch.Edit

'///////////////////////////////PROJECT ORIGIN POINT/////////////////////////////

Dim oOrigin As WorkPoint
	oOrigin = oPartComp.WorkPoints.Item(1)
		Dim oOriginPoint As SketchEntity = oPlanarSketch.AddByProjectingEntity(oOrigin)

'//////////////////////FINALY DRAW THE ACTUAL PART SKETCH////////////////////////

Dim oPoint1 As Point2d = oTG.CreatePoint2d(0, 0)
Dim oPoint2 As Point2d = oTG.CreatePoint2d(0, 3.3)

Dim oValue1 As Double = oGap1.Value + 3 + 5
Dim oPoint3 As Point2d = oTG.CreatePoint2d(oValue1,3.3)

Dim oLine1 As SketchLine = oPlanarSketch.SketchLines.AddByTwoPoints(oPoint1, oPoint2)
	Dim oDimention1 As TwoPointDistanceDimConstraint = oPlanarSketch.DimensionConstraints.AddTwoPointDistance(oLine1.StartSketchPoint,oLine1.EndSketchPoint,DimensionOrientationEnum.kAlignedDim,oLine1.Geometry.MidPoint)
		oLine1.StartSketchPoint.Merge(oOriginPoint)
		oPlanarSketch.GeometricConstraints.AddVertical(oLine1)
		
Dim oLine2 As SketchLine = oPlanarSketch.SketchLines.AddByTwoPoints(oPoint2, oPoint3)
	Dim oDimention2 As TwoPointDistanceDimConstraint = oPlanarSketch.DimensionConstraints.AddTwoPointDistance(oLine2.StartSketchPoint,oLine2.EndSketchPoint,DimensionOrientationEnum.kAlignedDim,oLine2.Geometry.MidPoint)
		oDimention2.Parameter.Expression = "Gap_1 + 30 + 50"
		oLine1.EndSketchPoint.Merge(oLine2.StartSketchPoint)
		oPlanarSketch.GeometricConstraints.AddPerpendicular(oLine1, oLine2)
	
Dim oPoint4 As Point2d = oTG.CreatePoint2d(oPoint3.X,0.8)	
	
Dim oLine3 As SketchLine = oPlanarSketch.SketchLines.AddByTwoPoints(oPoint3, oPoint4)
	Dim oDimention3 As TwoPointDistanceDimConstraint = oPlanarSketch.DimensionConstraints.AddTwoPointDistance(oLine3.StartSketchPoint, oLine3.EndSketchPoint, DimensionOrientationEnum.kAlignedDim, oLine3.Geometry.MidPoint)
		oLine3.StartSketchPoint.Merge(oLine2.EndSketchPoint)
		oPlanarSketch.GeometricConstraints.AddPerpendicular(oLine2, oLine3)
		
Dim oPoint5 As Point2d = oTG.CreatePoint2d(3, oPoint4.Y)	

Dim oLine4 As SketchLine = oPlanarSketch.SketchLines.AddByTwoPoints(oPoint4, oPoint5)
	oLine4.StartSketchPoint.Merge(oLine3.EndSketchPoint)
	oPlanarSketch.GeometricConstraints.AddPerpendicular(oLine3, oLine4)
	
Dim oPoint6 As Point2d = oTG.CreatePoint2d(3, 0)	

Dim oLine5 As SketchLine = oPlanarSketch.SketchLines.AddByTwoPoints(oPoint5, oPoint6)
	oLine5.StartSketchPoint.Merge(oLine4.EndSketchPoint)
	oPlanarSketch.GeometricConstraints.AddPerpendicular(oLine4, oLine5)

Dim oLine6 As SketchLine = oPlanarSketch.SketchLines.AddByTwoPoints(oPoint6, oPoint1)
	Dim oDimention4 As TwoPointDistanceDimConstraint = oPlanarSketch.DimensionConstraints.AddTwoPointDistance(oLine6.StartSketchPoint,oLine6.EndSketchPoint,DimensionOrientationEnum.kAlignedDim,oLine6.Geometry.MidPoint)
		oLine6.StartSketchPoint.Merge(oLine5.EndSketchPoint)
		oLine6.EndSketchPoint.Merge(oLine1.StartSketchPoint)
		oPlanarSketch.GeometricConstraints.AddPerpendicular(oLine5, oLine6)	

oPlanarSketch.ExitEdit

'//////////////////////////////EXTRUDE THE SKETCH/////////////////////////////

Dim oProfile As Profile 
oProfile = oPlanarSketch.Profiles.AddForSolid

Dim oExtrude1 As ExtrudeFeature = oPartComp.Features.ExtrudeFeatures.AddByDistanceExtent(oProfile, 0.5 , kSymmetricExtentDirection, kJoinOperation)
oExtrude1.Name = "Extrusion1"

'/////////////////////////////////CHANGE COLOR////////////////////////////////

Dim oAppearence As Asset
oAppearence = oDoc.Assets.Add(kAssetTypeAppearance, "Generic", "Appearances")

Dim oColor As ColorAssetValue
oColor = oAppearence.Item("generic_diffuse")

oColor.Value = ThisApplication.TransientObjects.CreateColor(0,145,255)

oExtrude1.Appearance = oAppearence

 Hope this helps ,

Regards,

FINET L.