Announcements
Attention for Customers without Multi-Factor Authentication or Single Sign-On - OTP Verification rolls out April 2025. Read all about it here.

Sure!

 

This is the most important one. 

 

Sub Main()
	'Prevents Inventor from crashing.
	'---------------------------------------------------------------------------------------------
	InventorVb.DocumentUpdate()

	'Check if open document is sheetmetal
	'---------------------------------------------------------------------------------------------

	Dim oDoc As Document = ThisApplication.ActiveDocument
	If oDoc.DocumentSubType.DocumentSubTypeID <> "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}" Then
		Exit Sub
	Else
	End If
	'MsgBox("Is sheetmetal")

	'Check if open sheetmetal document has flatpattern view
	'---------------------------------------------------------------------------------------------
	Dim oSMD As SheetMetalComponentDefinition
	oSMD = oDoc.ComponentDefinition
	If Not oSMD.HasFlatPattern Then Exit Sub
	Dim oFlat As FlatPattern = oSMD.FlatPattern
	'MsgBox("Has flatpattern")

	'Check for bend features
	'---------------------------------------------------------------------------------------------
	Try
		Dim BendCount As Integer = oSMD.Bends.Count
		If BendCount < 1 Then Exit Sub
		'MsgBox("# bends " & BendCount)
	Catch
		'MsgBox("error: Sheetmetalcomponentdefinition.Bends.Count (Can't find bends?)")
		Exit Sub
	End Try

	'Check if feature "BendMarkerHoles" exists
	'---------------------------------------------------------------------------------------------
	Dim FeatureName As String = "BendMarkerHoles"

	Try
		Dim oFTS As FlatPatternFeatures = oFlat.Features
		If oFTS.Count > 0 Then
			For Each oFT As PartFeature In oFTS
				If oFT.Name <> FeatureName Then Continue For
				Try
					oFT.Delete()
				Catch

				End Try
				Exit For
			Next
		End If
	Catch
		MsgBox("error in MAIN()")
	End Try

	BendMarker(oFlat)

End Sub

Sub BendMarker(oFlat As FlatPattern)
	Dim oEdges As Edges
	Dim oHoleCenters As Object = ThisApplication.TransientObjects.CreateObjectCollection
	Dim oSketch As PlanarSketch

	'Flatpattern sketch -------------------------------------------------------------------------
	Try
		oSketch = oFlat.Sketches.Add(oFlat.TopFace, True)
	Catch
		oSketch = oFlat.Sketches.Add(oFlat.BottomFace, True)
	End Try

	oSketch.Edit()

	'Detect bend down ---------------------------------------------------------------------------
	Try
		oEdges = oFlat.GetEdgesOfType(FlatPatternEdgeTypeEnum.kBendDownFlatPatternEdge, True)
		WorkEdges(oHoleCenters, oSketch, oEdges)
	Catch
		MsgBox("error: GetEdgesOfType 64005/kBendDownFlatPatternEdge")
	End Try

	'Detect bend up -----------------------------------------------------------------------------
	Try
		oEdges = oFlat.GetEdgesOfType(FlatPatternEdgeTypeEnum.kBendUpFlatPatternEdge, True)
		WorkEdges(oHoleCenters, oSketch, oEdges)
	Catch
		MsgBox("error: GetEdgesOfType 64004/kBendUpFlatPatternEdge")
	End Try
	Call oFlat.Features.HoleFeatures.AddDrilledByThroughAllExtent(oHoleCenters, 0.1, kPositiveExtentDirection)

	Try
		Dim oHoleFeat As HoleFeature = oFlat.Features.HoleFeatures.Item(1)
		oHoleFeat.Name = "BendMarkerHoles"

		oSketch.ExitEdit()
		oSketch.Name = "MarkedBends"
	Catch
		MsgBox("error: GetEdgesOfType kBendUpFlatPatternEdge (64004) en/of kBendDownFlatPatternEdge (64005) kunnen niet worden gevonden")
	End Try
	
End Sub

Sub WorkEdges(ByRef oHoleCenters As Object, ByRef oSketch As PlanarSketch, oEdges As Edges)

	'Create list of coördinates
	'-------------------------------------------------------------------------------------------
	Dim oDoc As Document = ThisDoc.Document
	Dim oSMD As SheetMetalComponentDefinition
	oSMD = oDoc.ComponentDefinition

	Dim oLoft As Integer = 0
	For Each HFeature As LoftedFlangeFeature In oSMD.Features.LoftedFlangeFeatures
		oLoft = 1
	Next

	Dim oTG As TransientGeometry = ThisApplication.TransientGeometry

	Dim Xi As Integer = 0

	Dim BendCount As Integer = oSMD.Bends.Count
	BendCount *= 4
	Dim oPointGrid(BendCount, 1) As Double

	For Each oEdge As Edge In oEdges
		Try
			Dim oEnt As SketchEntity = oSketch.AddByProjectingEntity(oEdge)

			oPointGrid(Xi, 0) = oEnt.StartSketchPoint.Geometry.X.ToString
			oPointGrid(Xi, 1) = oEnt.StartSketchPoint.Geometry.Y.ToString

			Xi = Xi + 1
			oPointGrid(Xi, 0) = oEnt.EndSketchPoint.Geometry.X.ToString
			oPointGrid(Xi, 1) = oEnt.EndSketchPoint.Geometry.Y.ToString
			Xi = Xi + 1

			oEnt.Delete	'Deleting projected geometry
		Catch
			'MsgBox("error")
		End Try
	Next

	If Xi = 0 Then Exit Sub

	'Loft Filter Start
	'--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
	If oLoft = 0 Then GoTo Endloft
	'MsgBox("Loft Code")

	Dim intCount1, intCount2 As Integer
	Dim DictX As Object = CreateObject("Scripting.Dictionary")
	Dim DictY As Object = CreateObject("Scripting.Dictionary")

	'Filter Points within certain promximity of each other
	'-------------------------------------------------------------
	For intCount1 = 0 To Xi
		For intCount2 = 0 To Xi
			If intCount1 <> intCount2 Then
				'																		2D-array
				'																		 |_0__|_1__|
				'																		0|_X__|_Y__|	0,0 = x coördinate 0,1 = y coördinate
				'																		1|_X__|_Y__|	1,0 = x coördinate 1,1 = y coördinate
				'																		2|_X__|_Y__|	2,0 = x coördinate 2,1 = y coördinate			


				'											X-Value intCount1		  X-Value intCount2									Y-Value intCount1	   	  Y-Value intCount2			
				'						Compare			2D Array Cel X,0	With	  2D Array Cel X,0			And		Compare			2D Array Cel X,1	With	  2D Array Cel X,1
				If EqualWithinTolerance(oPointGrid(intCount1, 0), oPointGrid(intCount2, 0), 0.1) And EqualWithinTolerance(oPointGrid(intCount1, 1), oPointGrid(intCount2, 1), 0.1) Then
					Try
						DictX.Add(oPointGrid(intCount2, 0) & " " & oPointGrid(intCount2, 1), oPointGrid(intCount2, 0))
						DictY.Add(oPointGrid(intCount2, 0) & " " & oPointGrid(intCount2, 1), oPointGrid(intCount2, 1))
					Catch
						'Nothing
					End Try
				End If
			End If
		Next intCount2
	Next intCount1
	'MsgBox("IntCount " & intCount1 & " " & intCount2)

	'Filter points.
	'Only the points which are not close to each other remain.
	'-------------------------------------------------------------
	Dim i As Integer = 0
	Dim oPointGridFilteredX As Object = CreateObject("Scripting.Dictionary")
	Dim oPointGridFilteredY As Object = CreateObject("Scripting.Dictionary")

	For i = 0 To Xi
		If Not Xi = 0 Then
			If Not DictX.Exists(oPointGrid(i, 0) & " " & oPointGrid(i, 1)) Then
				oPointGridFilteredX.Add(oPointGrid(i, 0) & " " & oPointGrid(i, 1), oPointGrid(i, 0))
				oPointGridFilteredY.Add(oPointGrid(i, 0) & " " & oPointGrid(i, 1), oPointGrid(i, 1))
			Else
				'Nothing
			End If
		End If
	Next

	'Convert the created dictionary of filtered points into an 2d-array
	'-------------------------------------------------------------
	Dim ArrayFiltered(oPointGridFilteredX.Count - 1, 1) As Double
	Dim ii As Integer = 1

	For ii = 0 To oPointGridFilteredX.Count - 1
		ArrayFiltered(ii, 0) = oPointGridFilteredX.Items()(ii)
		ArrayFiltered(ii, 1) = oPointGridFilteredY.Items()(ii)
	Next

	'Place holecenters
	'--------------------------------------------
	Dim iii As Integer = 0

	For iii = 0 To ii - 1
		Dim oP = oSketch.SketchPoints.Add(oTG.CreatePoint2d(ArrayFiltered(iii, 0), ArrayFiltered(iii, 1)), True)
		'MsgBox("oP " & ArrayFiltered(iii, 0) & " " & ArrayFiltered(iii, 1))
		If Not (ArrayFiltered(iii, 0) = 0 And ArrayFiltered(iii, 1) = 0) Then
			'MsgBox("oP " & ArrayFiltered(iii, 0) & " " & ArrayFiltered(iii, 1))
			oHoleCenters.Add(oP)
		End If
	Next

	'Loft Filter End
	'--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------		

	'Place holecenters
	'--------------------------------------------
	If oLoft = 1 Then Exit Sub

	Endloft :
	'MsgBox("Non Loft Code")

	For Each oEdge As Edge In oEdges
		Dim oEnt As SketchEntity = oSketch.AddByProjectingEntity(oEdge)
		Dim P As Point2d = oEnt.StartSketchPoint.Geometry
		Dim oSP As SketchPoint = oSketch.SketchPoints.Add(oTG.CreatePoint2d(P.X, P.Y), True)
		oHoleCenters.Add(oSP)
		P = oEnt.EndSketchPoint.Geometry
		Dim oEP As SketchPoint = oSketch.SketchPoints.Add(oTG.CreatePoint2d(P.X, P.Y), True)
		oHoleCenters.Add(oEP)
	Next
End Sub

Did you find this reply helpful ? If so please use the Accept as Solution or Kudos button below.

___________________________