It's still very much a work in progress but I'm trying to build one with iLogic
Option Explicit
Sub Main()
Dim app As Inventor.Application = ThisApplication
Dim tg As TransientGeometry = app.TransientGeometry
Dim srcAsm As AssemblyDocument = app.ActiveDocument
Dim basePath As String
basePath = Left(srcAsm.FullFileName, InStrRev(srcAsm.FullFileName, "\"))
' ---------------- Paramètres ----------------
Dim kerfMM As Double: kerfMM = 3.175 ' 1/8"
Dim stockLenMM As Double: stockLenMM = 7315.2 ' 288"
Dim gabaritPath As String
gabaritPath = "C:\Vault WS\Designs\DIVERS\Mathieu G\Tests iLogic\OptiCutter\OptiCutter-Template.iam"
' ---------------- Préparer dictionnaire familles ----------------
Dim families As New Dictionary(Of String, List(Of Object()))
Dim keywords() As String: keywords = Split("POUTRE|CORNIÈRE|TUBE|TUYAU|ACIER PLAT|ACIER ROND|HSS", "|")
' Collecter récursivement
Dim occ As ComponentOccurrence
For Each occ In srcAsm.ComponentDefinition.Occurrences
CollectParts(occ, families, keywords)
Next
If families.Count = 0 Then
MessageBox.Show("Aucun profilé détecté.", "OptiCutter")
Exit Sub
End If
' ---------------- FFD + génération ----------------
Dim fKey As String
For Each fKey In families.Keys
Dim parts As List(Of Object())
parts = families(fKey)
SortByLengthDesc(parts)
' Optimisation: First-Fit Decreasing
Dim bars As New List(Of List(Of Object()))
Dim p As Object()
For Each p In parts
Dim L As Double: L = CDbl(p(1))
Dim placed As Boolean: placed = False
Dim b As List(Of Object())
For Each b In bars
Dim used As Double: used = SumLengths(b) + KerfTotal(b.Count, kerfMM)
Dim extraKerf As Double: extraKerf = IIf(b.Count > 0, kerfMM, 0)
If used + extraKerf + L <= stockLenMM Then
b.Add(p)
placed = True
Exit For
End If
Next
If Not placed Then
Dim nb As New List(Of Object())
nb.Add(p)
bars.Add(nb)
End If
Next
' Générer un assemblage par barre
Dim barIdx As Integer: barIdx = 1
Dim b2 As List(Of Object())
For Each b2 In bars
If Not System.IO.File.Exists(gabaritPath) Then
MessageBox.Show("Gabarit introuvable: " & gabaritPath, "OptiCutter")
Exit Sub
End If
Dim newAsm As AssemblyDocument
newAsm = app.Documents.Open(gabaritPath, True)
newAsm.DisplayName = "PlanCoupe_" & CleanName(fKey) & "_Barre" & barIdx
Dim compDef As AssemblyComponentDefinition = newAsm.ComponentDefinition
' Plans assemblage (mapping)
Dim asmXY As WorkPlane, asmYZ As WorkPlane, asmXZ As WorkPlane
asmXY = compDef.WorkPlanes.Item(3)
asmYZ = compDef.WorkPlanes.Item(1)
asmXZ = compDef.WorkPlanes.Item(2)
Dim offsetMM As Double: offsetMM = 0
Dim first As Boolean: first = True
Dim q As Object()
For Each q In b2
Dim path As String: path = CStr(q(0))
Dim Lmm As Double: Lmm = CDbl(q(1))
If Not System.IO.File.Exists(path) Then Continue For
Dim occNew As ComponentOccurrence
occNew = compDef.Occurrences.Add(path, tg.CreateMatrix())
Dim pDef As PartComponentDefinition = TryCast(occNew.Definition, PartComponentDefinition)
If pDef Is Nothing Then Continue For
' Plans pièce (mapping)
Dim wpXY As WorkPlane, wpYZ As WorkPlane, wpXZ As WorkPlane
wpXY = pDef.WorkPlanes.Item(3)
wpYZ = pDef.WorkPlanes.Item(1)
wpXZ = pDef.WorkPlanes.Item(2)
' Proxies
Dim xyProxy As WorkPlaneProxy, yzProxy As WorkPlaneProxy, xzProxy As WorkPlaneProxy
occNew.CreateGeometryProxy(wpXY, xyProxy)
occNew.CreateGeometryProxy(wpYZ, yzProxy)
occNew.CreateGeometryProxy(wpXZ, xzProxy)
' Contraintes
compDef.Constraints.AddFlushConstraint(asmXZ, xzProxy, 0)
compDef.Constraints.AddFlushConstraint(asmYZ, yzProxy, 0)
Dim offCM As Double: offCM = IIf(first, 0, offsetMM / 10.0)
compDef.Constraints.AddFlushConstraint(asmXY, xyProxy, offCM)
first = False
' Avancer offset
offsetMM += Lmm
If Not IsLastInBar(b2, q) Then offsetMM += kerfMM
Next
' Sauvegarder et fermer
Dim savePath As String
savePath = basePath & newAsm.DisplayName & ".iam"
newAsm.SaveAs(savePath, False)
'newAsm.Close(False)
barIdx += 1
Next
Next
MessageBox.Show("Optimisation terminée: barres générées par famille.", "OptiCutter")
End Sub
' ===== Helpers =====
Private Sub CollectParts(occ As ComponentOccurrence, ByRef families As Dictionary(Of String, List(Of Object())), ByVal keywords() As String)
If TypeOf occ.Definition Is PartComponentDefinition Then
Dim partDoc As Document = occ.Definition.Document
Dim desc As String, dest As String
desc = "" : dest = ""
On Error Resume Next
desc = CStr(iProperties.Value(occ.Name, "Project", "Description"))
dest = CStr(iProperties.Value(occ.Name, "Custom", "Destination"))
On Error GoTo 0
Dim keep As Boolean: keep = False
If desc <> "" Then
Dim up As String: up = UCase(desc)
Dim k As Integer
For k = LBound(keywords) To UBound(keywords)
If InStr(up, keywords(k)) > 0 Then keep = True : Exit For
Next
End If
If LCase(dest) = "scie" Then keep = True
If keep And desc <> "" Then
Dim Lmm As Double: Lmm = 0
On Error Resume Next
Lmm = CDbl(partDoc.ComponentDefinition.Parameters.UserParameters.Item("Longueur").Value) * 10
If Err.Number <> 0 Then
Err.Clear()
Lmm = CDbl(partDoc.ComponentDefinition.Parameters.UserParameters.Item("G_L").Value) * 10
End If
On Error GoTo 0
If Lmm > 0 Then
Dim famKey As String: famKey = Trim(UCase(desc))
If Not families.ContainsKey(famKey) Then families.Add(famKey, New List(Of Object()))
families(famKey).Add(New Object(){partDoc.FullFileName, Lmm})
End If
End If
ElseIf TypeOf occ.Definition Is AssemblyComponentDefinition Then
Dim subOcc As ComponentOccurrence
For Each subOcc In occ.SubOccurrences
CollectParts(subOcc, families, keywords)
Next
End If
End Sub
Private Sub SortByLengthDesc(ByRef lst As List(Of Object()))
Dim n As Integer: n = lst.Count
Dim i As Integer, j As Integer
For i = 0 To n - 2
For j = i + 1 To n - 1
If CDbl(lst(i)(1)) < CDbl(lst(j)(1)) Then
Dim tmp As Object(): tmp = lst(i)
lst(i) = lst(j)
lst(j) = tmp
End If
Next
Next
End Sub
Private Function SumLengths(lst As List(Of Object())) As Double
Dim s As Double: s = 0
Dim it As Object()
For Each it In lst
s = s + CDbl(it(1))
Next
SumLengths = s
End Function
Private Function KerfTotal(count As Integer, kerfMM As Double) As Double
If count <= 1 Then
KerfTotal = 0
Else
KerfTotal = (count - 1) * kerfMM
End If
End Function
Private Function IsLastInBar(lst As List(Of Object()), item As Object()) As Boolean
IsLastInBar = (Object.ReferenceEquals(lst(lst.Count - 1), item))
End Function
Private Function CleanName(s As String) As String
' Supprime caractères illégaux pour noms de fichiers
Dim badChars As String: badChars = "\/:*?""<>|"
Dim c As String
For Each c In badChars
s = Replace(s, c, "_")
Next
CleanName = s
End Function
