'==============================================================================
' ObliczeniaBlach.iLogicVb - Autodesk Inventor iLogic rule (single file)
' Analog of SheetMetalCalc.bas (SolidWorks) / Preliminary Cost Estimate panel.
'
' WHAT THIS RULE DOES
' For the active sheet-metal Part:
' - reads part name / thickness / material / weight
' - ensures FlatPattern (Unfold if missing)
' - measures area, blank (+ allowance), laser path, bend count / length
' - computes material / cut / bend / engraver / total price
' Shows a text report (MsgBox) and optionally saves .txt next to the model:
' {name}_{material}_{thickness}_{yyyy-MM-dd_HH-mm-ss}.txt
'
' HOW TO USE
' 1) Edit SETTINGS (Cfg* Functions below) - prices, allowance, TXT, notify.
' 2) Inventor: External Rules -> Add Rule -> select this .iLogicVb
' (prefer local disk, not W:\ / OneDrive - same tip as Save.iLogicVb).
' 3) Open a SAVED sheet-metal Part, run the rule.
'
' CONFIG (Cfg*) - change Return values only:
' CfgDecimalPlaces, CfgMaterialAllowanceMm, CfgPricePerBend,
' CfgPricePerMmBendLineEngraver, CfgPricePerMmCutPer1MmThickness,
' CfgMaterialPrice, CfgMaterialPricePerKg, CfgMaterialNet,
' CfgExportTxt, CfgNotify
'
' RETURN / REPORT
' BuildReport() always returns text. Empty / error lines mean calculation failed.
' Settings block is appended so a TXT export can restore inputs later.
'
' NOTES FOR BEGINNERS
' - iLogic = VB.NET (not VBA). Sub Main must come first.
' - Do NOT put Dim / Const / Shared above Main - iLogic will not compile.
' Settings are Functions that Return a value (same idea as VBA Const / Save.iLogicVb).
' - ThisApplication is given by iLogic.
' - Inventor database length = cm -> mm via *10; area cm2 -> mm2 via *100.
' - Use "mm2" (ASCII), not Unicode superscript - safer in MsgBox / TXT.
'==============================================================================
'===== ENTRY ==================================================================
Sub Main()
' ok: True when we produced a usable report (and optional TXT write succeeded)
Dim report As String = ""
Dim path As String = ""
Dim ok As Boolean = True
Try
Dim oDoc As Document = ThisApplication.ActiveDocument
If oDoc Is Nothing Then
MsgBox("No document open.", MsgBoxStyle.Exclamation, "SheetMetalCalc")
Return
End If
report = BuildReport(oDoc)
' Heuristic: short "not a sheet part" / empty is still a report, but mark fail for icon
ok = (report.Length > 0) AndAlso _
(report.IndexOf("No document", StringComparison.OrdinalIgnoreCase) < 0) AndAlso _
(report.IndexOf("not a sheet part", StringComparison.OrdinalIgnoreCase) < 0)
' Optional TXT next to the model (needs FullFileName)
If CfgExportTxt() AndAlso ok AndAlso HasSavedPath(oDoc) Then
path = BuildTxtPath(oDoc)
If path.Length > 0 Then
If WriteTextFile(path, report) Then
report = report & vbCrLf & ModuleSep() & vbCrLf & _
PadKey("export") & " - " & path
Else
report = report & vbCrLf & ModuleSep() & vbCrLf & _
"Export failed: could not write TXT."
ok = False
End If
End If
End If
If CfgNotify() = 1 OrElse Not ok Then
Dim icon As MsgBoxStyle = If(ok, MsgBoxStyle.Information, MsgBoxStyle.Exclamation)
MsgBox(report, icon, "SheetMetalCalc")
End If
Catch ex As Exception
MsgBox("SheetMetalCalc error: " & ex.Message, MsgBoxStyle.Critical, "SheetMetalCalc")
End Try
End Sub
'----- SETTINGS (edit Return values) ------------------------------------------
' *** EDIT ONLY THIS BLOCK to configure prices / allowance / export ***
' Same meaning as the SW panel / SheetMetalCalc.bas inputs.
' Change the Return value, then save the rule and run again.
' Implemented as Functions: iLogic forbids module-level Const/fields
' (same pattern as Save.iLogicVb CfgExportPdf / CfgNotify / ...).
Function CfgDecimalPlaces() As Integer
' How many digits after the decimal in report numbers (area, blank, prices, ...).
' Example: 2 -> "12.50"; 0 -> "13".
Return 2
End Function
Function CfgMaterialAllowanceMm() As Double
' Extra stock on EACH side of the blank (mm).
' Blank size = flat Length/Width + 2 * allowance (both sides).
' Example: 1.0 -> +1 mm left and +1 mm right (same for height).
Return 1.0
End Function
Function CfgPricePerBend() As Double
' Money charged PER bend (bend count from flat-pattern bend edges).
' Bending price = bendCount * CfgPricePerBend.
Return 2.0
End Function
Function CfgPricePerMmBendLineEngraver() As Double
' Money per mm of bend CENTERLINE (engraver / marking along the bend).
' Engraver price = totalBendLengthMm * this rate.
Return 0.1
End Function
Function CfgPricePerMmCutPer1MmThickness() As Double
' Laser cutting rate.
' Cutting price = laserPathLengthMm * thicknessMm * this rate.
' (Longer cut and thicker sheet = higher price.)
Return 13.55
End Function
Function CfgMaterialPrice() As Double
' Material unit price. Unit depends on CfgMaterialPricePerKg:
' True -> currency per 1 kg
' False -> currency per 1 m2
Return 12.0
End Function
Function CfgMaterialPricePerKg() As Boolean
' How to interpret CfgMaterialPrice:
' True = Per 1 kg (uses part mass / estimated blank mass)
' False = Per 1 m2 (uses net area or blank area in m2)
Return True
End Function
Function CfgMaterialNet() As Boolean
' Which area drives material quantity:
' True = Area (Net) - unfolded face area / mass of the part
' False = Blank (Gross) - rectangular blank including allowance
Return False
End Function
Function CfgExportTxt() As Boolean
' True = also save the report as .txt next to the part file
' name: {part}_{material}_{thickness}_{yyyy-MM-dd_HH-mm-ss}.txt
' False = only MsgBox, no file
Return True
End Function
Function CfgNotify() As Integer
' 0 = show MsgBox only when something failed
' 1 = always show the full report MsgBox (default)
Return 1
End Function
'----- FIXED LABELS (usually do not edit) -------------------------------------
' Layout helpers for the text report - not pricing settings.
Function KeyCol() As Integer
' Pad width for short report keys ("part", "thickness", "price", ...).
Return 12
End Function
Function SettingsKeyCol() As Integer
' Pad width for the Settings block keys (longer labels).
Return 24
End Function
Function ModuleSep() As String
' Separator line between report sections ("---").
Return "---"
End Function
Function UndefLabel() As String
' Placeholder when thickness / material / name cannot be read.
Return "undefined"
End Function
Function SheetMetalSubtype() As String
' Inventor Part SubType GUID that marks a sheet-metal part.
Return "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}"
End Function
'===== REPORT =================================================================
Function BuildReport(oDoc As Document) As String
' Build the full human-readable cost report for one sheet-metal part.
Dim isSm As Boolean = False
Dim infoPart As String = UndefLabel()
Dim infoThk As String = UndefLabel()
Dim infoMat As String = UndefLabel()
Dim infoW As String = UndefLabel()
Dim hasWeight As Boolean = False
Dim hasThk As Boolean = False
Dim weightKg As Double = 0
Dim thkMm As Double = 0
Dim canMsg As String = ""
Dim areaMm2 As Double = 0
Dim blankL As Double = 0
Dim blankW As Double = 0
Dim blankA As Double = 0
Dim laserMm As Double = 0
Dim bendLenMm As Double = 0
Dim bendCnt As Integer = 0
Dim hasArea As Boolean = False
Dim hasBlank As Boolean = False
Dim hasLaser As Boolean = False
Dim hasBendCnt As Boolean = False
Dim hasBendLen As Boolean = False
Dim hasOverlap As Boolean = False
Dim overlapMsg As String = ""
Dim matCost As Double? = Nothing
Dim cutCost As Double? = Nothing
Dim bendCost As Double? = Nothing
Dim engCost As Double? = Nothing
Dim totalTxt As String = ""
Dim modules As String = ""
Dim sheetBlock As String = ""
Dim engBlock As String = ""
GetPartInfo(oDoc, isSm, infoPart, infoThk, infoMat, infoW, hasWeight, weightKg, hasThk, thkMm)
If Not isSm Then
Return "Document is not a sheet part." & vbCrLf & _
"(Open a part with Flat Pattern / sheet metal.)" & _
vbCrLf & ModuleSep() & vbCrLf & BuildSettingsBlock()
End If
If Not CanFlatten(oDoc, canMsg) Then
Return PartHeader(infoPart, infoThk, infoMat, hasWeight, infoW) & _
PadKey("price") & " - (not calculated)" & vbCrLf & _
ModuleSep() & vbCrLf & canMsg & _
vbCrLf & ModuleSep() & vbCrLf & BuildSettingsBlock()
End If
If Not CalcOnFlatPattern(oDoc, areaMm2, hasArea, blankL, blankW, blankA, hasBlank, _
laserMm, hasLaser, bendCnt, hasBendCnt, bendLenMm, hasBendLen, _
hasOverlap, overlapMsg) Then
Return PartHeader(infoPart, infoThk, infoMat, hasWeight, infoW) & _
PadKey("price") & " - (not calculated)" & vbCrLf & _
ModuleSep() & vbCrLf & _
"Cannot flatten this part: Flat-Pattern/Flatten operation is unavailable." & _
vbCrLf & ModuleSep() & vbCrLf & BuildSettingsBlock()
End If
If hasOverlap Then
Return PartHeader(infoPart, infoThk, infoMat, hasWeight, infoW) & _
PadKey("price") & " - (not calculated)" & vbCrLf & _
ModuleSep() & vbCrLf & _
Nz(overlapMsg, "Geometry check found issues in flat pattern.") & _
vbCrLf & ModuleSep() & vbCrLf & BuildSettingsBlock()
End If
' No bends -> bend length is zero (engraver line not needed)
If hasBendCnt AndAlso bendCnt <= 0 Then
bendLenMm = 0
hasBendLen = True
End If
matCost = CalcMaterialCost(hasWeight, weightKg, hasArea, areaMm2, hasBlank, blankA)
cutCost = CalcCutCost(hasLaser, laserMm, hasThk, thkMm)
bendCost = CalcBendCost(hasBendCnt, bendCnt)
engCost = CalcEngraverCost(hasBendLen, bendLenMm)
totalTxt = FormatTotalPrice(matCost, cutCost, bendCost, engCost)
modules = PartHeader(infoPart, infoThk, infoMat, hasWeight, infoW) & _
PadKey("price") & " - " & totalTxt
' --- Sheet / laser / bends block ---
sheetBlock = "Sheet OK" & vbCrLf
If hasArea Then
sheetBlock &= PadKey("area") & " - " & FmtNum(areaMm2, CfgDecimalPlaces()) & " mm2" & vbCrLf
End If
If hasBlank Then
sheetBlock &= PadKey("blank") & " - " & _
FmtNum(blankL, CfgDecimalPlaces()) & " x " & FmtNum(blankW, CfgDecimalPlaces()) & " mm (" & _
FmtNum(blankA, CfgDecimalPlaces()) & " mm2), allowance +" & _
FmtNumG(CfgMaterialAllowanceMm()) & " mm per side (from settings)" & vbCrLf
End If
sheetBlock &= PadKey("material price") & " - " & FormatMoney(matCost) & vbCrLf
sheetBlock &= ModuleSep() & vbCrLf & "Laser cut" & vbCrLf
If hasLaser Then
sheetBlock &= PadKey("length") & " - " & FmtNum(laserMm, CfgDecimalPlaces()) & " mm" & vbCrLf
sheetBlock &= PadKey("cutting price") & " - " & FormatMoney(cutCost) & vbCrLf
Else
sheetBlock &= PadKey("length") & " - -" & vbCrLf
sheetBlock &= PadKey("cutting price") & " - (not calculated)" & vbCrLf
End If
sheetBlock &= ModuleSep() & vbCrLf & "Bends" & vbCrLf
sheetBlock &= PadKey("count") & " - " & If(hasBendCnt, bendCnt.ToString(), "0") & vbCrLf
sheetBlock &= PadKey("bending price") & " - " & FormatMoney(bendCost)
modules &= vbCrLf & ModuleSep() & vbCrLf & sheetBlock
' --- Engraver block (price along bend lines) ---
engBlock = "Engraver" & vbCrLf
If hasBendLen Then
engBlock &= PadKey("length") & " - " & FmtNum(bendLenMm, CfgDecimalPlaces()) & " mm" & vbCrLf
Else
engBlock &= PadKey("length") & " - -" & vbCrLf
End If
engBlock &= PadKey("rate") & " - " & FmtNumG(CfgPricePerMmBendLineEngraver()) & vbCrLf
engBlock &= PadKey("price") & " - " & FormatMoney(engCost)
modules &= vbCrLf & ModuleSep() & vbCrLf & engBlock
modules &= vbCrLf & ModuleSep() & vbCrLf & BuildSettingsBlock()
Return modules
End Function
Function PartHeader(partName As String, thk As String, mat As String, _
hasWeight As Boolean, weight As String) As String
' First lines of every report: part / thickness / material [/ weight].
Dim s As String = PadKey("part") & " - " & partName & " loaded" & vbCrLf & _
PadKey("thickness") & " - " & thk & vbCrLf & _
PadKey("material") & " - " & mat & vbCrLf
If hasWeight Then s &= PadKey("weight") & " - " & weight & vbCrLf
Return s
End Function
Function BuildSettingsBlock() As String
' Appended to every report so TXT export records the inputs that were used.
Dim s As String = "Settings" & vbCrLf
s &= PadSettingsKey("decimal places") & " - " & ClampDec(CfgDecimalPlaces()).ToString() & vbCrLf
s &= PadSettingsKey("material allowance") & " - " & FmtNumG(CfgMaterialAllowanceMm()) & " mm" & vbCrLf
s &= PadSettingsKey("price per bend") & " - " & FmtNumG(CfgPricePerBend()) & vbCrLf
s &= PadSettingsKey("price per mm engraver") & " - " & FmtNumG(CfgPricePerMmBendLineEngraver()) & vbCrLf
s &= PadSettingsKey("price per mm cut") & " - " & FmtNumG(CfgPricePerMmCutPer1MmThickness()) & vbCrLf
s &= PadSettingsKey("material price") & " - " & FmtNumG(CfgMaterialPrice()) & vbCrLf
s &= PadSettingsKey("material price unit") & " - " & If(CfgMaterialPricePerKg(), "Per 1 kg", "Per 1 m2") & vbCrLf
s &= PadSettingsKey("material quantity") & " - " & If(CfgMaterialNet(), "Area", "Blank")
Return s
End Function
'===== SMALL HELPERS ==========================================================
Function IsBlank(s As String) As Boolean
Return String.IsNullOrEmpty(s)
End Function
Function Nz(value As String, fallback As String) As String
If IsBlank(value) Then Return fallback
Return value
End Function
Function HasSavedPath(oDoc As Document) As Boolean
' Unsaved docs have empty FullFileName - cannot write TXT next to model.
Try
Return Not IsBlank(oDoc.FullFileName)
Catch
Return False
End Try
End Function
Function PadKey(key As String) As String
' Left-align key in a fixed column so the report looks like a table.
If key.Length >= KeyCol() Then Return key
Return key & New String(" "c, KeyCol() - key.Length)
End Function
Function PadSettingsKey(key As String) As String
If key.Length >= SettingsKeyCol() Then Return key
Return key & New String(" "c, SettingsKeyCol() - key.Length)
End Function
Function FmtNum(v As Double, dec As Integer) As String
' Fixed decimal places, invariant culture (dot as decimal separator).
Return v.ToString("F" & ClampDec(dec).ToString(), System.Globalization.CultureInfo.InvariantCulture)
End Function
Function FmtNumG(v As Double) As String
' General format (settings / rates).
Return v.ToString("G", System.Globalization.CultureInfo.InvariantCulture)
End Function
Function FormatMoney(v As Double?) As String
' Nullable Double: Nothing -> "(not calculated)".
If Not v.HasValue Then Return "(not calculated)"
Return FmtNum(v.Value, 2)
End Function
Function ClampDec(n As Integer) As Integer
If n < 0 Then Return 0
If n > 10 Then Return 10
Return n
End Function
'===== PART INFO ==============================================================
Sub GetPartInfo(oDoc As Document, ByRef isSm As Boolean, ByRef partName As String, _
ByRef thickness As String, ByRef material As String, ByRef weight As String, _
ByRef hasWeight As Boolean, ByRef weightKg As Double, _
ByRef hasThk As Boolean, ByRef thkMm As Double)
' Fill display strings + numeric thickness/weight for pricing.
isSm = False
partName = UndefLabel()
thickness = UndefLabel()
material = UndefLabel()
weight = UndefLabel()
hasWeight = False
weightKg = 0
hasThk = False
thkMm = 0
Try
partName = oDoc.DisplayName
If IsBlank(partName) Then partName = UndefLabel()
Catch
partName = UndefLabel()
End Try
If Not IsSheetMetalPart(oDoc) Then Return
isSm = True
Try
Dim sm As SheetMetalComponentDefinition = GetSmDef(oDoc)
thkMm = sm.Thickness.Value * 10.0 ' cm -> mm
If thkMm > 0 Then
hasThk = True
thickness = FmtNum(thkMm, CfgDecimalPlaces()) & " mm"
End If
Catch
End Try
Try
Dim pDoc As PartDocument = CType(oDoc, PartDocument)
Dim mat As Material = pDoc.ActiveMaterial
If mat IsNot Nothing AndAlso Not String.IsNullOrWhiteSpace(mat.DisplayName) Then
material = mat.DisplayName
End If
Catch
material = UndefLabel()
End Try
' Mass only if material is known (same rule as SW panel)
If material <> UndefLabel() Then
Try
Dim sm As SheetMetalComponentDefinition = GetSmDef(oDoc)
Dim mass As Double = sm.MassProperties.Mass
If mass >= 0 Then
hasWeight = True
weightKg = mass
weight = FmtNum(mass, CfgDecimalPlaces()) & " kg"
End If
Catch
hasWeight = False
End Try
End If
End Sub
Function IsSheetMetalPart(oDoc As Document) As Boolean
Try
If oDoc.DocumentType <> DocumentTypeEnum.kPartDocumentObject Then Return False
Dim pDoc As PartDocument = CType(oDoc, PartDocument)
If String.Equals(pDoc.SubType, SheetMetalSubtype(), StringComparison.OrdinalIgnoreCase) Then Return True
Return TypeOf pDoc.ComponentDefinition Is SheetMetalComponentDefinition
Catch
Return False
End Try
End Function
Function GetSmDef(oDoc As Document) As SheetMetalComponentDefinition
' Call only after IsSheetMetalPart is True.
Dim pDoc As PartDocument = CType(oDoc, PartDocument)
Return CType(pDoc.ComponentDefinition, SheetMetalComponentDefinition)
End Function
'===== FLATTEN / GEOMETRY =====================================================
Function CanFlatten(oDoc As Document, ByRef msg As String) As Boolean
' Ensure a FlatPattern exists (Unfold if needed). msg explains failure.
msg = ""
Try
If Not IsSheetMetalPart(oDoc) Then
msg = "Active document is not a part."
Return False
End If
Dim sm As SheetMetalComponentDefinition = GetSmDef(oDoc)
If Not sm.HasFlatPattern Then
Try
sm.Unfold()
Catch
msg = "Cannot flatten this part: Flat-Pattern/Flatten operation is unavailable."
Return False
End Try
End If
If sm.FlatPattern Is Nothing Then
msg = "Cannot flatten this part: Flat pattern body is unavailable."
Return False
End If
msg = "Flat pattern is available."
Return True
Catch
msg = "Cannot flatten this part: an error occurred while preparing Flat Pattern."
Return False
End Try
End Function
Function CalcOnFlatPattern(oDoc As Document, _
ByRef areaMm2 As Double, ByRef hasArea As Boolean, _
ByRef blankL As Double, ByRef blankW As Double, ByRef blankA As Double, ByRef hasBlank As Boolean, _
ByRef laserMm As Double, ByRef hasLaser As Boolean, _
ByRef bendCnt As Integer, ByRef hasBendCnt As Boolean, _
ByRef bendLenMm As Double, ByRef hasBendLen As Boolean, _
ByRef hasOverlap As Boolean, ByRef overlapMsg As String) As Boolean
' Measure manufacturing geometry on the flat pattern.
hasArea = False : hasBlank = False : hasLaser = False
hasBendCnt = False : hasBendLen = False
hasOverlap = False
overlapMsg = ""
Try
Dim sm As SheetMetalComponentDefinition = GetSmDef(oDoc)
If Not sm.HasFlatPattern Then
Try
sm.Unfold()
Catch
Return False
End Try
End If
Dim fp As FlatPattern = sm.FlatPattern
If fp Is Nothing Then Return False
' Inventor has no Body.Check2 like the SW panel - skip overlap, treat as OK
hasOverlap = False
overlapMsg = "Geometry check skipped (Inventor)."
' Area: TopFace evaluator returns cm2 -> mm2 (*100)
Try
Dim areaCm2 As Double = fp.TopFace.Evaluator.Area
If areaCm2 > 0 Then
areaMm2 = areaCm2 * 100.0
hasArea = True
End If
Catch
End Try
' Blank: FlatPattern Length/Width (cm->*10) + allowance per side
Try
Dim lenMm As Double = fp.Length * 10.0
Dim widMm As Double = fp.Width * 10.0
Dim allow As Double = CfgMaterialAllowanceMm()
If lenMm >= widMm Then
blankL = lenMm + 2.0 * allow
blankW = widMm + 2.0 * allow
Else
blankL = widMm + 2.0 * allow
blankW = lenMm + 2.0 * allow
End If
blankA = blankL * blankW
hasBlank = True
Catch
End Try
' Laser path: sum of all TopFace edge-loop lengths (outer + holes), cm -> mm
Try
Dim totalCm As Double = 0
Dim mt As MeasureTools = ThisApplication.MeasureTools
Dim lp As EdgeLoop
For Each lp In fp.TopFace.EdgeLoops
totalCm += mt.GetLoopLength(lp)
Next
If totalCm > 0 Then
laserMm = totalCm * 10.0
hasLaser = True
End If
Catch
End Try
' Bends: unique bend edges on top face (up + down), grouped if colinear
Dim bc As Integer = 0
Dim blMm As Double = 0
GetBendMetrics(fp, bc, blMm)
bendCnt = bc
bendLenMm = blMm
hasBendCnt = True
hasBendLen = True
Return True
Catch
Return False
End Try
End Function
Sub GetBendMetrics(fp As FlatPattern, ByRef bendCount As Integer, ByRef bendLengthMm As Double)
' Count bends and total bend-line length on the flat pattern.
' Preferred: kBendUp / kBendDown edges, merge colinear connected pieces.
' Fallback: FlatBendResults (divide by 2 because top+bottom duplicates).
bendCount = 0
bendLengthMm = 0
Try
Dim edges As New List(Of Edge)
Try
Dim up As Edges = fp.GetEdgesOfType(FlatPatternEdgeTypeEnum.kBendUpFlatPatternEdge, True)
Dim e As Edge
For Each e In up
edges.Add(e)
Next
Catch
End Try
Try
Dim down As Edges = fp.GetEdgesOfType(FlatPatternEdgeTypeEnum.kBendDownFlatPatternEdge, True)
Dim e2 As Edge
For Each e2 In down
edges.Add(e2)
Next
Catch
End Try
If edges.Count = 0 Then
Try
Dim res As FlatBendResults = fp.FlatBendResults
If res IsNot Nothing AndAlso res.Count > 0 Then
bendCount = CInt(Math.Ceiling(res.Count / 2.0))
Dim totalCm As Double = 0
Dim i As Integer
For i = 1 To res.Count
Try
If Not res.Item(i).IsOnBottomFace Then
totalCm += EdgeLengthCm(res.Item(i).Edge)
End If
Catch
End Try
Next
bendLengthMm = totalCm * 10.0
End If
Catch
End Try
Return
End If
' Precompute length / endpoints / direction for each bend edge
Dim n As Integer = edges.Count
Dim visited(n - 1) As Boolean
Dim lens(n - 1) As Double
Dim p1(n - 1) As Point
Dim p2(n - 1) As Point
Dim dir(n - 1) As UnitVector
Dim tg As TransientGeometry = ThisApplication.TransientGeometry
Dim iEdge As Integer
For iEdge = 0 To n - 1
lens(iEdge) = EdgeLengthCm(edges(iEdge))
Try
p1(iEdge) = edges(iEdge).StartVertex.Point
p2(iEdge) = edges(iEdge).StopVertex.Point
Dim vx As Double = p2(iEdge).X - p1(iEdge).X
Dim vy As Double = p2(iEdge).Y - p1(iEdge).Y
Dim vz As Double = p2(iEdge).Z - p1(iEdge).Z
Dim len As Double = Math.Sqrt(vx * vx + vy * vy + vz * vz)
If len > 0.0000001 Then
dir(iEdge) = tg.CreateUnitVector(vx / len, vy / len, vz / len)
Else
dir(iEdge) = Nothing
End If
Catch
dir(iEdge) = Nothing
End Try
Next
' BFS: connect edges that share an endpoint and are nearly parallel
Dim groups As Integer = 0
Dim totalLenCm As Double = 0
Dim tol As Double = 0.0001
Dim cosTol As Double = 0.9999
For iEdge = 0 To n - 1
If visited(iEdge) OrElse dir(iEdge) Is Nothing Then Continue For
groups += 1
Dim q As New Queue(Of Integer)
visited(iEdge) = True
q.Enqueue(iEdge)
Dim groupLen As Double = 0
Do While q.Count > 0
Dim j As Integer = q.Dequeue()
groupLen += lens(j)
Dim k As Integer
For k = 0 To n - 1
If visited(k) OrElse dir(k) Is Nothing Then Continue For
If Not ShareEndpointPts(p1(j), p2(j), p1(k), p2(k), tol) Then Continue For
Dim dot As Double = dir(j).X * dir(k).X + dir(j).Y * dir(k).Y + dir(j).Z * dir(k).Z
If Math.Abs(dot) < cosTol Then Continue For
visited(k) = True
q.Enqueue(k)
Next
Loop
totalLenCm += groupLen
Next
bendCount = groups
bendLengthMm = totalLenCm * 10.0
Catch
bendCount = 0
bendLengthMm = 0
End Try
End Sub
Function EdgeLengthCm(e As Edge) As Double
' Curve length in Inventor database units (cm).
Try
Dim ev As CurveEvaluator = e.Evaluator
Dim minP As Double = 0
Dim maxP As Double = 0
Dim length As Double = 0
ev.GetParamExtents(minP, maxP)
ev.GetLengthAtParam(minP, maxP, length)
Return length
Catch
Return 0
End Try
End Function
Function ShareEndpointPts(a1 As Point, a2 As Point, b1 As Point, b2 As Point, tol As Double) As Boolean
' True if two segments share an endpoint within tol (distance squared).
If a1 Is Nothing OrElse a2 Is Nothing OrElse b1 Is Nothing OrElse b2 Is Nothing Then Return False
Dim t2 As Double = tol * tol
Return Dist2(a1, b1) <= t2 OrElse Dist2(a1, b2) <= t2 OrElse Dist2(a2, b1) <= t2 OrElse Dist2(a2, b2) <= t2
End Function
Function Dist2(a As Point, b As Point) As Double
Dim dx As Double = a.X - b.X
Dim dy As Double = a.Y - b.Y
Dim dz As Double = a.Z - b.Z
Return dx * dx + dy * dy + dz * dz
End Function
'===== PRICING ================================================================
Function CalcMaterialCost(hasWeight As Boolean, weightKg As Double, _
hasArea As Boolean, areaMm2 As Double, _
hasBlank As Boolean, blankAreaMm2 As Double) As Double?
' Material cost from CfgMaterialNet / CfgMaterialPricePerKg settings.
' Area and blank are in mm2; convert to m2 with / 1e6 when pricing by area.
If CfgMaterialNet() Then
If CfgMaterialPricePerKg() Then
If hasWeight AndAlso weightKg >= 0 Then Return weightKg * CfgMaterialPrice()
Return Nothing
Else
If hasArea AndAlso areaMm2 > 0 Then Return (areaMm2 / 1000000.0) * CfgMaterialPrice()
Return Nothing
End If
Else
If CfgMaterialPricePerKg() Then
' Scale part mass by blank/net area ratio (gross material mass estimate)
If Not hasBlank OrElse blankAreaMm2 <= 0 Then Return Nothing
If Not hasArea OrElse areaMm2 <= 0 OrElse Not hasWeight OrElse weightKg < 0 Then Return Nothing
Dim blankMass As Double = weightKg * (blankAreaMm2 / areaMm2)
Return blankMass * CfgMaterialPrice()
Else
If hasBlank AndAlso blankAreaMm2 > 0 Then Return (blankAreaMm2 / 1000000.0) * CfgMaterialPrice()
Return Nothing
End If
End If
End Function
Function CalcCutCost(hasLaser As Boolean, laserMm As Double, hasThk As Boolean, thkMm As Double) As Double?
' Laser: length * thickness * rate (all must be valid and > 0).
If Not hasLaser OrElse laserMm <= 0 Then Return Nothing
If Not hasThk OrElse thkMm <= 0 Then Return Nothing
If CfgPricePerMmCutPer1MmThickness() <= 0 Then Return Nothing
Return laserMm * thkMm * CfgPricePerMmCutPer1MmThickness()
End Function
Function CalcBendCost(hasCnt As Boolean, cnt As Integer) As Double?
If Not hasCnt OrElse cnt <= 0 Then Return Nothing
If CfgPricePerBend() <= 0 Then Return Nothing
Return CDbl(cnt) * CfgPricePerBend()
End Function
Function CalcEngraverCost(hasLen As Boolean, lenMm As Double) As Double?
If Not hasLen OrElse lenMm <= 0 Then Return Nothing
If CfgPricePerMmBendLineEngraver() <= 0 Then Return Nothing
Return lenMm * CfgPricePerMmBendLineEngraver()
End Function
Function FormatTotalPrice(matCost As Double?, cutCost As Double?, _
bendCost As Double?, engCost As Double?) As String
' Work = cut + bend + engraver. Total = material + work when material known.
Dim workOnly As Double = 0
If cutCost.HasValue Then workOnly += cutCost.Value
If bendCost.HasValue Then workOnly += bendCost.Value
If engCost.HasValue Then workOnly += engCost.Value
If Not matCost.HasValue Then
Return FmtNum(workOnly, 2) & " (work price, material excluded)"
End If
Return FmtNum(matCost.Value + workOnly, 2)
End Function
'===== TXT EXPORT =============================================================
Function BuildTxtPath(oDoc As Document) As String
' {folder}\{part}_{material}_{thickness}_{stamp}.txt
Try
Dim docPath As String = oDoc.FullFileName
If IsBlank(docPath) Then Return ""
Dim isSm As Boolean = False
Dim partName As String = ""
Dim thk As String = ""
Dim mat As String = ""
Dim w As String = ""
Dim hasW As Boolean = False
Dim wKg As Double = 0
Dim hasT As Boolean = False
Dim tMm As Double = 0
GetPartInfo(oDoc, isSm, partName, thk, mat, w, hasW, wKg, hasT, tMm)
Dim dir As String = System.IO.Path.GetDirectoryName(docPath)
Dim baseName As String = System.IO.Path.GetFileNameWithoutExtension(docPath)
Dim stamp As String = DateTime.Now.ToString("yyyy-MM-dd_HH-mm-ss", System.Globalization.CultureInfo.InvariantCulture)
Dim fileName As String = baseName & "_" & SafeFilePart(mat) & "_" & SafeFilePart(thk) & "_" & stamp & ".txt"
Return System.IO.Path.Combine(dir, fileName)
Catch
Return ""
End Try
End Function
Function SafeFilePart(value As String) As String
' Strip characters illegal in Windows file names.
If String.IsNullOrWhiteSpace(value) OrElse value = UndefLabel() Then Return "unknown"
Dim s As String = value.Trim()
Dim bad As String = "\:*?""<>|/"
Dim i As Integer
For i = 1 To bad.Length
s = s.Replace(bad.Substring(i - 1, 1), "_")
Next
s = System.Text.RegularExpressions.Regex.Replace(s, "\s+", "_")
If IsBlank(s) Then s = "unknown"
Return s
End Function
Function WriteTextFile(path As String, content As String) As Boolean
Try
System.IO.File.WriteAllText(path, content, System.Text.Encoding.UTF8)
Return True
Catch
Return False
End Try
End Function
'==============================================================================
' ObliczeniaBlach.iLogicVb - Autodesk Inventor iLogic rule (single file)
' Analog of SheetMetalCalc.bas (SolidWorks) / Preliminary Cost Estimate panel.
'
' WHAT THIS RULE DOES
' For the active sheet-metal Part:
' - reads part name / thickness / material / weight
' - ensures FlatPattern (Unfold if missing)
' - measures area, blank (+ allowance), laser path, bend count / length
' - computes material / cut / bend / engraver / total price
' Shows a text report (MsgBox) and optionally saves .txt next to the model:
' {name}_{material}_{thickness}_{yyyy-MM-dd_HH-mm-ss}.txt
'
' HOW TO USE
' 1) Edit SETTINGS (Cfg* Functions below) - prices, allowance, TXT, notify.
' 2) Inventor: External Rules -> Add Rule -> select this .iLogicVb
' (prefer local disk, not W:\ / OneDrive - same tip as Save.iLogicVb).
' 3) Open a SAVED sheet-metal Part, run the rule.
'
' CONFIG (Cfg*) - change Return values only:
' CfgDecimalPlaces, CfgMaterialAllowanceMm, CfgPricePerBend,
' CfgPricePerMmBendLineEngraver, CfgPricePerMmCutPer1MmThickness,
' CfgMaterialPrice, CfgMaterialPricePerKg, CfgMaterialNet,
' CfgExportTxt, CfgNotify
'
' RETURN / REPORT
' BuildReport() always returns text. Empty / error lines mean calculation failed.
' Settings block is appended so a TXT export can restore inputs later.
'
' NOTES FOR BEGINNERS
' - iLogic = VB.NET (not VBA). Sub Main must come first.
' - Do NOT put Dim / Const / Shared above Main - iLogic will not compile.
' Settings are Functions that Return a value (same idea as VBA Const / Save.iLogicVb).
' - ThisApplication is given by iLogic.
' - Inventor database length = cm -> mm via *10; area cm2 -> mm2 via *100.
' - Use "mm2" (ASCII), not Unicode superscript - safer in MsgBox / TXT.
'==============================================================================
'===== ENTRY ==================================================================
Sub Main()
' ok: True when we produced a usable report (and optional TXT write succeeded)
Dim report As String = ""
Dim path As String = ""
Dim ok As Boolean = True
Try
Dim oDoc As Document = ThisApplication.ActiveDocument
If oDoc Is Nothing Then
MsgBox("No document open.", MsgBoxStyle.Exclamation, "SheetMetalCalc")
Return
End If
report = BuildReport(oDoc)
' Heuristic: short "not a sheet part" / empty is still a report, but mark fail for icon
ok = (report.Length > 0) AndAlso _
(report.IndexOf("No document", StringComparison.OrdinalIgnoreCase) < 0) AndAlso _
(report.IndexOf("not a sheet part", StringComparison.OrdinalIgnoreCase) < 0)
' Optional TXT next to the model (needs FullFileName)
If CfgExportTxt() AndAlso ok AndAlso HasSavedPath(oDoc) Then
path = BuildTxtPath(oDoc)
If path.Length > 0 Then
If WriteTextFile(path, report) Then
report = report & vbCrLf & ModuleSep() & vbCrLf & _
PadKey("export") & " - " & path
Else
report = report & vbCrLf & ModuleSep() & vbCrLf & _
"Export failed: could not write TXT."
ok = False
End If
End If
End If
If CfgNotify() = 1 OrElse Not ok Then
Dim icon As MsgBoxStyle = If(ok, MsgBoxStyle.Information, MsgBoxStyle.Exclamation)
MsgBox(report, icon, "SheetMetalCalc")
End If
Catch ex As Exception
MsgBox("SheetMetalCalc error: " & ex.Message, MsgBoxStyle.Critical, "SheetMetalCalc")
End Try
End Sub
'----- SETTINGS (edit Return values) ------------------------------------------
' *** EDIT ONLY THIS BLOCK to configure prices / allowance / export ***
' Same meaning as the SW panel / SheetMetalCalc.bas inputs.
' Change the Return value, then save the rule and run again.
' Implemented as Functions: iLogic forbids module-level Const/fields
' (same pattern as Save.iLogicVb CfgExportPdf / CfgNotify / ...).
Function CfgDecimalPlaces() As Integer
' How many digits after the decimal in report numbers (area, blank, prices, ...).
' Example: 2 -> "12.50"; 0 -> "13".
Return 2
End Function
Function CfgMaterialAllowanceMm() As Double
' Extra stock on EACH side of the blank (mm).
' Blank size = flat Length/Width + 2 * allowance (both sides).
' Example: 1.0 -> +1 mm left and +1 mm right (same for height).
Return 1.0
End Function
Function CfgPricePerBend() As Double
' Money charged PER bend (bend count from flat-pattern bend edges).
' Bending price = bendCount * CfgPricePerBend.
Return 2.0
End Function
Function CfgPricePerMmBendLineEngraver() As Double
' Money per mm of bend CENTERLINE (engraver / marking along the bend).
' Engraver price = totalBendLengthMm * this rate.
Return 0.1
End Function
Function CfgPricePerMmCutPer1MmThickness() As Double
' Laser cutting rate.
' Cutting price = laserPathLengthMm * thicknessMm * this rate.
' (Longer cut and thicker sheet = higher price.)
Return 13.55
End Function
Function CfgMaterialPrice() As Double
' Material unit price. Unit depends on CfgMaterialPricePerKg:
' True -> currency per 1 kg
' False -> currency per 1 m2
Return 12.0
End Function
Function CfgMaterialPricePerKg() As Boolean
' How to interpret CfgMaterialPrice:
' True = Per 1 kg (uses part mass / estimated blank mass)
' False = Per 1 m2 (uses net area or blank area in m2)
Return True
End Function
Function CfgMaterialNet() As Boolean
' Which area drives material quantity:
' True = Area (Net) - unfolded face area / mass of the part
' False = Blank (Gross) - rectangular blank including allowance
Return False
End Function
Function CfgExportTxt() As Boolean
' True = also save the report as .txt next to the part file
' name: {part}_{material}_{thickness}_{yyyy-MM-dd_HH-mm-ss}.txt
' False = only MsgBox, no file
Return True
End Function
Function CfgNotify() As Integer
' 0 = show MsgBox only when something failed
' 1 = always show the full report MsgBox (default)
Return 1
End Function
'----- FIXED LABELS (usually do not edit) -------------------------------------
' Layout helpers for the text report - not pricing settings.
Function KeyCol() As Integer
' Pad width for short report keys ("part", "thickness", "price", ...).
Return 12
End Function
Function SettingsKeyCol() As Integer
' Pad width for the Settings block keys (longer labels).
Return 24
End Function
Function ModuleSep() As String
' Separator line between report sections ("---").
Return "---"
End Function
Function UndefLabel() As String
' Placeholder when thickness / material / name cannot be read.
Return "undefined"
End Function
Function SheetMetalSubtype() As String
' Inventor Part SubType GUID that marks a sheet-metal part.
Return "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}"
End Function
'===== REPORT =================================================================
Function BuildReport(oDoc As Document) As String
' Build the full human-readable cost report for one sheet-metal part.
Dim isSm As Boolean = False
Dim infoPart As String = UndefLabel()
Dim infoThk As String = UndefLabel()
Dim infoMat As String = UndefLabel()
Dim infoW As String = UndefLabel()
Dim hasWeight As Boolean = False
Dim hasThk As Boolean = False
Dim weightKg As Double = 0
Dim thkMm As Double = 0
Dim canMsg As String = ""
Dim areaMm2 As Double = 0
Dim blankL As Double = 0
Dim blankW As Double = 0
Dim blankA As Double = 0
Dim laserMm As Double = 0
Dim bendLenMm As Double = 0
Dim bendCnt As Integer = 0
Dim hasArea As Boolean = False
Dim hasBlank As Boolean = False
Dim hasLaser As Boolean = False
Dim hasBendCnt As Boolean = False
Dim hasBendLen As Boolean = False
Dim hasOverlap As Boolean = False
Dim overlapMsg As String = ""
Dim matCost As Double? = Nothing
Dim cutCost As Double? = Nothing
Dim bendCost As Double? = Nothing
Dim engCost As Double? = Nothing
Dim totalTxt As String = ""
Dim modules As String = ""
Dim sheetBlock As String = ""
Dim engBlock As String = ""
GetPartInfo(oDoc, isSm, infoPart, infoThk, infoMat, infoW, hasWeight, weightKg, hasThk, thkMm)
If Not isSm Then
Return "Document is not a sheet part." & vbCrLf & _
"(Open a part with Flat Pattern / sheet metal.)" & _
vbCrLf & ModuleSep() & vbCrLf & BuildSettingsBlock()
End If
If Not CanFlatten(oDoc, canMsg) Then
Return PartHeader(infoPart, infoThk, infoMat, hasWeight, infoW) & _
PadKey("price") & " - (not calculated)" & vbCrLf & _
ModuleSep() & vbCrLf & canMsg & _
vbCrLf & ModuleSep() & vbCrLf & BuildSettingsBlock()
End If
If Not CalcOnFlatPattern(oDoc, areaMm2, hasArea, blankL, blankW, blankA, hasBlank, _
laserMm, hasLaser, bendCnt, hasBendCnt, bendLenMm, hasBendLen, _
hasOverlap, overlapMsg) Then
Return PartHeader(infoPart, infoThk, infoMat, hasWeight, infoW) & _
PadKey("price") & " - (not calculated)" & vbCrLf & _
ModuleSep() & vbCrLf & _
"Cannot flatten this part: Flat-Pattern/Flatten operation is unavailable." & _
vbCrLf & ModuleSep() & vbCrLf & BuildSettingsBlock()
End If
If hasOverlap Then
Return PartHeader(infoPart, infoThk, infoMat, hasWeight, infoW) & _
PadKey("price") & " - (not calculated)" & vbCrLf & _
ModuleSep() & vbCrLf & _
Nz(overlapMsg, "Geometry check found issues in flat pattern.") & _
vbCrLf & ModuleSep() & vbCrLf & BuildSettingsBlock()
End If
' No bends -> bend length is zero (engraver line not needed)
If hasBendCnt AndAlso bendCnt <= 0 Then
bendLenMm = 0
hasBendLen = True
End If
matCost = CalcMaterialCost(hasWeight, weightKg, hasArea, areaMm2, hasBlank, blankA)
cutCost = CalcCutCost(hasLaser, laserMm, hasThk, thkMm)
bendCost = CalcBendCost(hasBendCnt, bendCnt)
engCost = CalcEngraverCost(hasBendLen, bendLenMm)
totalTxt = FormatTotalPrice(matCost, cutCost, bendCost, engCost)
modules = PartHeader(infoPart, infoThk, infoMat, hasWeight, infoW) & _
PadKey("price") & " - " & totalTxt
' --- Sheet / laser / bends block ---
sheetBlock = "Sheet OK" & vbCrLf
If hasArea Then
sheetBlock &= PadKey("area") & " - " & FmtNum(areaMm2, CfgDecimalPlaces()) & " mm2" & vbCrLf
End If
If hasBlank Then
sheetBlock &= PadKey("blank") & " - " & _
FmtNum(blankL, CfgDecimalPlaces()) & " x " & FmtNum(blankW, CfgDecimalPlaces()) & " mm (" & _
FmtNum(blankA, CfgDecimalPlaces()) & " mm2), allowance +" & _
FmtNumG(CfgMaterialAllowanceMm()) & " mm per side (from settings)" & vbCrLf
End If
sheetBlock &= PadKey("material price") & " - " & FormatMoney(matCost) & vbCrLf
sheetBlock &= ModuleSep() & vbCrLf & "Laser cut" & vbCrLf
If hasLaser Then
sheetBlock &= PadKey("length") & " - " & FmtNum(laserMm, CfgDecimalPlaces()) & " mm" & vbCrLf
sheetBlock &= PadKey("cutting price") & " - " & FormatMoney(cutCost) & vbCrLf
Else
sheetBlock &= PadKey("length") & " - -" & vbCrLf
sheetBlock &= PadKey("cutting price") & " - (not calculated)" & vbCrLf
End If
sheetBlock &= ModuleSep() & vbCrLf & "Bends" & vbCrLf
sheetBlock &= PadKey("count") & " - " & If(hasBendCnt, bendCnt.ToString(), "0") & vbCrLf
sheetBlock &= PadKey("bending price") & " - " & FormatMoney(bendCost)
modules &= vbCrLf & ModuleSep() & vbCrLf & sheetBlock
' --- Engraver block (price along bend lines) ---
engBlock = "Engraver" & vbCrLf
If hasBendLen Then
engBlock &= PadKey("length") & " - " & FmtNum(bendLenMm, CfgDecimalPlaces()) & " mm" & vbCrLf
Else
engBlock &= PadKey("length") & " - -" & vbCrLf
End If
engBlock &= PadKey("rate") & " - " & FmtNumG(CfgPricePerMmBendLineEngraver()) & vbCrLf
engBlock &= PadKey("price") & " - " & FormatMoney(engCost)
modules &= vbCrLf & ModuleSep() & vbCrLf & engBlock
modules &= vbCrLf & ModuleSep() & vbCrLf & BuildSettingsBlock()
Return modules
End Function
Function PartHeader(partName As String, thk As String, mat As String, _
hasWeight As Boolean, weight As String) As String
' First lines of every report: part / thickness / material [/ weight].
Dim s As String = PadKey("part") & " - " & partName & " loaded" & vbCrLf & _
PadKey("thickness") & " - " & thk & vbCrLf & _
PadKey("material") & " - " & mat & vbCrLf
If hasWeight Then s &= PadKey("weight") & " - " & weight & vbCrLf
Return s
End Function
Function BuildSettingsBlock() As String
' Appended to every report so TXT export records the inputs that were used.
Dim s As String = "Settings" & vbCrLf
s &= PadSettingsKey("decimal places") & " - " & ClampDec(CfgDecimalPlaces()).ToString() & vbCrLf
s &= PadSettingsKey("material allowance") & " - " & FmtNumG(CfgMaterialAllowanceMm()) & " mm" & vbCrLf
s &= PadSettingsKey("price per bend") & " - " & FmtNumG(CfgPricePerBend()) & vbCrLf
s &= PadSettingsKey("price per mm engraver") & " - " & FmtNumG(CfgPricePerMmBendLineEngraver()) & vbCrLf
s &= PadSettingsKey("price per mm cut") & " - " & FmtNumG(CfgPricePerMmCutPer1MmThickness()) & vbCrLf
s &= PadSettingsKey("material price") & " - " & FmtNumG(CfgMaterialPrice()) & vbCrLf
s &= PadSettingsKey("material price unit") & " - " & If(CfgMaterialPricePerKg(), "Per 1 kg", "Per 1 m2") & vbCrLf
s &= PadSettingsKey("material quantity") & " - " & If(CfgMaterialNet(), "Area", "Blank")
Return s
End Function
'===== SMALL HELPERS ==========================================================
Function IsBlank(s As String) As Boolean
Return String.IsNullOrEmpty(s)
End Function
Function Nz(value As String, fallback As String) As String
If IsBlank(value) Then Return fallback
Return value
End Function
Function HasSavedPath(oDoc As Document) As Boolean
' Unsaved docs have empty FullFileName - cannot write TXT next to model.
Try
Return Not IsBlank(oDoc.FullFileName)
Catch
Return False
End Try
End Function
Function PadKey(key As String) As String
' Left-align key in a fixed column so the report looks like a table.
If key.Length >= KeyCol() Then Return key
Return key & New String(" "c, KeyCol() - key.Length)
End Function
Function PadSettingsKey(key As String) As String
If key.Length >= SettingsKeyCol() Then Return key
Return key & New String(" "c, SettingsKeyCol() - key.Length)
End Function
Function FmtNum(v As Double, dec As Integer) As String
' Fixed decimal places, invariant culture (dot as decimal separator).
Return v.ToString("F" & ClampDec(dec).ToString(), System.Globalization.CultureInfo.InvariantCulture)
End Function
Function FmtNumG(v As Double) As String
' General format (settings / rates).
Return v.ToString("G", System.Globalization.CultureInfo.InvariantCulture)
End Function
Function FormatMoney(v As Double?) As String
' Nullable Double: Nothing -> "(not calculated)".
If Not v.HasValue Then Return "(not calculated)"
Return FmtNum(v.Value, 2)
End Function
Function ClampDec(n As Integer) As Integer
If n < 0 Then Return 0
If n > 10 Then Return 10
Return n
End Function
'===== PART INFO ==============================================================
Sub GetPartInfo(oDoc As Document, ByRef isSm As Boolean, ByRef partName As String, _
ByRef thickness As String, ByRef material As String, ByRef weight As String, _
ByRef hasWeight As Boolean, ByRef weightKg As Double, _
ByRef hasThk As Boolean, ByRef thkMm As Double)
' Fill display strings + numeric thickness/weight for pricing.
isSm = False
partName = UndefLabel()
thickness = UndefLabel()
material = UndefLabel()
weight = UndefLabel()
hasWeight = False
weightKg = 0
hasThk = False
thkMm = 0
Try
partName = oDoc.DisplayName
If IsBlank(partName) Then partName = UndefLabel()
Catch
partName = UndefLabel()
End Try
If Not IsSheetMetalPart(oDoc) Then Return
isSm = True
Try
Dim sm As SheetMetalComponentDefinition = GetSmDef(oDoc)
thkMm = sm.Thickness.Value * 10.0 ' cm -> mm
If thkMm > 0 Then
hasThk = True
thickness = FmtNum(thkMm, CfgDecimalPlaces()) & " mm"
End If
Catch
End Try
Try
Dim pDoc As PartDocument = CType(oDoc, PartDocument)
Dim mat As Material = pDoc.ActiveMaterial
If mat IsNot Nothing AndAlso Not String.IsNullOrWhiteSpace(mat.DisplayName) Then
material = mat.DisplayName
End If
Catch
material = UndefLabel()
End Try
' Mass only if material is known (same rule as SW panel)
If material <> UndefLabel() Then
Try
Dim sm As SheetMetalComponentDefinition = GetSmDef(oDoc)
Dim mass As Double = sm.MassProperties.Mass
If mass >= 0 Then
hasWeight = True
weightKg = mass
weight = FmtNum(mass, CfgDecimalPlaces()) & " kg"
End If
Catch
hasWeight = False
End Try
End If
End Sub
Function IsSheetMetalPart(oDoc As Document) As Boolean
Try
If oDoc.DocumentType <> DocumentTypeEnum.kPartDocumentObject Then Return False
Dim pDoc As PartDocument = CType(oDoc, PartDocument)
If String.Equals(pDoc.SubType, SheetMetalSubtype(), StringComparison.OrdinalIgnoreCase) Then Return True
Return TypeOf pDoc.ComponentDefinition Is SheetMetalComponentDefinition
Catch
Return False
End Try
End Function
Function GetSmDef(oDoc As Document) As SheetMetalComponentDefinition
' Call only after IsSheetMetalPart is True.
Dim pDoc As PartDocument = CType(oDoc, PartDocument)
Return CType(pDoc.ComponentDefinition, SheetMetalComponentDefinition)
End Function
'===== FLATTEN / GEOMETRY =====================================================
Function CanFlatten(oDoc As Document, ByRef msg As String) As Boolean
' Ensure a FlatPattern exists (Unfold if needed). msg explains failure.
msg = ""
Try
If Not IsSheetMetalPart(oDoc) Then
msg = "Active document is not a part."
Return False
End If
Dim sm As SheetMetalComponentDefinition = GetSmDef(oDoc)
If Not sm.HasFlatPattern Then
Try
sm.Unfold()
Catch
msg = "Cannot flatten this part: Flat-Pattern/Flatten operation is unavailable."
Return False
End Try
End If
If sm.FlatPattern Is Nothing Then
msg = "Cannot flatten this part: Flat pattern body is unavailable."
Return False
End If
msg = "Flat pattern is available."
Return True
Catch
msg = "Cannot flatten this part: an error occurred while preparing Flat Pattern."
Return False
End Try
End Function
Function CalcOnFlatPattern(oDoc As Document, _
ByRef areaMm2 As Double, ByRef hasArea As Boolean, _
ByRef blankL As Double, ByRef blankW As Double, ByRef blankA As Double, ByRef hasBlank As Boolean, _
ByRef laserMm As Double, ByRef hasLaser As Boolean, _
ByRef bendCnt As Integer, ByRef hasBendCnt As Boolean, _
ByRef bendLenMm As Double, ByRef hasBendLen As Boolean, _
ByRef hasOverlap As Boolean, ByRef overlapMsg As String) As Boolean
' Measure manufacturing geometry on the flat pattern.
hasArea = False : hasBlank = False : hasLaser = False
hasBendCnt = False : hasBendLen = False
hasOverlap = False
overlapMsg = ""
Try
Dim sm As SheetMetalComponentDefinition = GetSmDef(oDoc)
If Not sm.HasFlatPattern Then
Try
sm.Unfold()
Catch
Return False
End Try
End If
Dim fp As FlatPattern = sm.FlatPattern
If fp Is Nothing Then Return False
' Inventor has no Body.Check2 like the SW panel - skip overlap, treat as OK
hasOverlap = False
overlapMsg = "Geometry check skipped (Inventor)."
' Area: TopFace evaluator returns cm2 -> mm2 (*100)
Try
Dim areaCm2 As Double = fp.TopFace.Evaluator.Area
If areaCm2 > 0 Then
areaMm2 = areaCm2 * 100.0
hasArea = True
End If
Catch
End Try
' Blank: FlatPattern Length/Width (cm->*10) + allowance per side
Try
Dim lenMm As Double = fp.Length * 10.0
Dim widMm As Double = fp.Width * 10.0
Dim allow As Double = CfgMaterialAllowanceMm()
If lenMm >= widMm Then
blankL = lenMm + 2.0 * allow
blankW = widMm + 2.0 * allow
Else
blankL = widMm + 2.0 * allow
blankW = lenMm + 2.0 * allow
End If
blankA = blankL * blankW
hasBlank = True
Catch
End Try
' Laser path: sum of all TopFace edge-loop lengths (outer + holes), cm -> mm
Try
Dim totalCm As Double = 0
Dim mt As MeasureTools = ThisApplication.MeasureTools
Dim lp As EdgeLoop
For Each lp In fp.TopFace.EdgeLoops
totalCm += mt.GetLoopLength(lp)
Next
If totalCm > 0 Then
laserMm = totalCm * 10.0
hasLaser = True
End If
Catch
End Try
' Bends: unique bend edges on top face (up + down), grouped if colinear
Dim bc As Integer = 0
Dim blMm As Double = 0
GetBendMetrics(fp, bc, blMm)
bendCnt = bc
bendLenMm = blMm
hasBendCnt = True
hasBendLen = True
Return True
Catch
Return False
End Try
End Function
Sub GetBendMetrics(fp As FlatPattern, ByRef bendCount As Integer, ByRef bendLengthMm As Double)
' Count bends and total bend-line length on the flat pattern.
' Preferred: kBendUp / kBendDown edges, merge colinear connected pieces.
' Fallback: FlatBendResults (divide by 2 because top+bottom duplicates).
bendCount = 0
bendLengthMm = 0
Try
Dim edges As New List(Of Edge)
Try
Dim up As Edges = fp.GetEdgesOfType(FlatPatternEdgeTypeEnum.kBendUpFlatPatternEdge, True)
Dim e As Edge
For Each e In up
edges.Add(e)
Next
Catch
End Try
Try
Dim down As Edges = fp.GetEdgesOfType(FlatPatternEdgeTypeEnum.kBendDownFlatPatternEdge, True)
Dim e2 As Edge
For Each e2 In down
edges.Add(e2)
Next
Catch
End Try
If edges.Count = 0 Then
Try
Dim res As FlatBendResults = fp.FlatBendResults
If res IsNot Nothing AndAlso res.Count > 0 Then
bendCount = CInt(Math.Ceiling(res.Count / 2.0))
Dim totalCm As Double = 0
Dim i As Integer
For i = 1 To res.Count
Try
If Not res.Item(i).IsOnBottomFace Then
totalCm += EdgeLengthCm(res.Item(i).Edge)
End If
Catch
End Try
Next
bendLengthMm = totalCm * 10.0
End If
Catch
End Try
Return
End If
' Precompute length / endpoints / direction for each bend edge
Dim n As Integer = edges.Count
Dim visited(n - 1) As Boolean
Dim lens(n - 1) As Double
Dim p1(n - 1) As Point
Dim p2(n - 1) As Point
Dim dir(n - 1) As UnitVector
Dim tg As TransientGeometry = ThisApplication.TransientGeometry
Dim iEdge As Integer
For iEdge = 0 To n - 1
lens(iEdge) = EdgeLengthCm(edges(iEdge))
Try
p1(iEdge) = edges(iEdge).StartVertex.Point
p2(iEdge) = edges(iEdge).StopVertex.Point
Dim vx As Double = p2(iEdge).X - p1(iEdge).X
Dim vy As Double = p2(iEdge).Y - p1(iEdge).Y
Dim vz As Double = p2(iEdge).Z - p1(iEdge).Z
Dim len As Double = Math.Sqrt(vx * vx + vy * vy + vz * vz)
If len > 0.0000001 Then
dir(iEdge) = tg.CreateUnitVector(vx / len, vy / len, vz / len)
Else
dir(iEdge) = Nothing
End If
Catch
dir(iEdge) = Nothing
End Try
Next
' BFS: connect edges that share an endpoint and are nearly parallel
Dim groups As Integer = 0
Dim totalLenCm As Double = 0
Dim tol As Double = 0.0001
Dim cosTol As Double = 0.9999
For iEdge = 0 To n - 1
If visited(iEdge) OrElse dir(iEdge) Is Nothing Then Continue For
groups += 1
Dim q As New Queue(Of Integer)
visited(iEdge) = True
q.Enqueue(iEdge)
Dim groupLen As Double = 0
Do While q.Count > 0
Dim j As Integer = q.Dequeue()
groupLen += lens(j)
Dim k As Integer
For k = 0 To n - 1
If visited(k) OrElse dir(k) Is Nothing Then Continue For
If Not ShareEndpointPts(p1(j), p2(j), p1(k), p2(k), tol) Then Continue For
Dim dot As Double = dir(j).X * dir(k).X + dir(j).Y * dir(k).Y + dir(j).Z * dir(k).Z
If Math.Abs(dot) < cosTol Then Continue For
visited(k) = True
q.Enqueue(k)
Next
Loop
totalLenCm += groupLen
Next
bendCount = groups
bendLengthMm = totalLenCm * 10.0
Catch
bendCount = 0
bendLengthMm = 0
End Try
End Sub
Function EdgeLengthCm(e As Edge) As Double
' Curve length in Inventor database units (cm).
Try
Dim ev As CurveEvaluator = e.Evaluator
Dim minP As Double = 0
Dim maxP As Double = 0
Dim length As Double = 0
ev.GetParamExtents(minP, maxP)
ev.GetLengthAtParam(minP, maxP, length)
Return length
Catch
Return 0
End Try
End Function
Function ShareEndpointPts(a1 As Point, a2 As Point, b1 As Point, b2 As Point, tol As Double) As Boolean
' True if two segments share an endpoint within tol (distance squared).
If a1 Is Nothing OrElse a2 Is Nothing OrElse b1 Is Nothing OrElse b2 Is Nothing Then Return False
Dim t2 As Double = tol * tol
Return Dist2(a1, b1) <= t2 OrElse Dist2(a1, b2) <= t2 OrElse Dist2(a2, b1) <= t2 OrElse Dist2(a2, b2) <= t2
End Function
Function Dist2(a As Point, b As Point) As Double
Dim dx As Double = a.X - b.X
Dim dy As Double = a.Y - b.Y
Dim dz As Double = a.Z - b.Z
Return dx * dx + dy * dy + dz * dz
End Function
'===== PRICING ================================================================
Function CalcMaterialCost(hasWeight As Boolean, weightKg As Double, _
hasArea As Boolean, areaMm2 As Double, _
hasBlank As Boolean, blankAreaMm2 As Double) As Double?
' Material cost from CfgMaterialNet / CfgMaterialPricePerKg settings.
' Area and blank are in mm2; convert to m2 with / 1e6 when pricing by area.
If CfgMaterialNet() Then
If CfgMaterialPricePerKg() Then
If hasWeight AndAlso weightKg >= 0 Then Return weightKg * CfgMaterialPrice()
Return Nothing
Else
If hasArea AndAlso areaMm2 > 0 Then Return (areaMm2 / 1000000.0) * CfgMaterialPrice()
Return Nothing
End If
Else
If CfgMaterialPricePerKg() Then
' Scale part mass by blank/net area ratio (gross material mass estimate)
If Not hasBlank OrElse blankAreaMm2 <= 0 Then Return Nothing
If Not hasArea OrElse areaMm2 <= 0 OrElse Not hasWeight OrElse weightKg < 0 Then Return Nothing
Dim blankMass As Double = weightKg * (blankAreaMm2 / areaMm2)
Return blankMass * CfgMaterialPrice()
Else
If hasBlank AndAlso blankAreaMm2 > 0 Then Return (blankAreaMm2 / 1000000.0) * CfgMaterialPrice()
Return Nothing
End If
End If
End Function
Function CalcCutCost(hasLaser As Boolean, laserMm As Double, hasThk As Boolean, thkMm As Double) As Double?
' Laser: length * thickness * rate (all must be valid and > 0).
If Not hasLaser OrElse laserMm <= 0 Then Return Nothing
If Not hasThk OrElse thkMm <= 0 Then Return Nothing
If CfgPricePerMmCutPer1MmThickness() <= 0 Then Return Nothing
Return laserMm * thkMm * CfgPricePerMmCutPer1MmThickness()
End Function
Function CalcBendCost(hasCnt As Boolean, cnt As Integer) As Double?
If Not hasCnt OrElse cnt <= 0 Then Return Nothing
If CfgPricePerBend() <= 0 Then Return Nothing
Return CDbl(cnt) * CfgPricePerBend()
End Function
Function CalcEngraverCost(hasLen As Boolean, lenMm As Double) As Double?
If Not hasLen OrElse lenMm <= 0 Then Return Nothing
If CfgPricePerMmBendLineEngraver() <= 0 Then Return Nothing
Return lenMm * CfgPricePerMmBendLineEngraver()
End Function
Function FormatTotalPrice(matCost As Double?, cutCost As Double?, _
bendCost As Double?, engCost As Double?) As String
' Work = cut + bend + engraver. Total = material + work when material known.
Dim workOnly As Double = 0
If cutCost.HasValue Then workOnly += cutCost.Value
If bendCost.HasValue Then workOnly += bendCost.Value
If engCost.HasValue Then workOnly += engCost.Value
If Not matCost.HasValue Then
Return FmtNum(workOnly, 2) & " (work price, material excluded)"
End If
Return FmtNum(matCost.Value + workOnly, 2)
End Function
'===== TXT EXPORT =============================================================
Function BuildTxtPath(oDoc As Document) As String
' {folder}\{part}_{material}_{thickness}_{stamp}.txt
Try
Dim docPath As String = oDoc.FullFileName
If IsBlank(docPath) Then Return ""
Dim isSm As Boolean = False
Dim partName As String = ""
Dim thk As String = ""
Dim mat As String = ""
Dim w As String = ""
Dim hasW As Boolean = False
Dim wKg As Double = 0
Dim hasT As Boolean = False
Dim tMm As Double = 0
GetPartInfo(oDoc, isSm, partName, thk, mat, w, hasW, wKg, hasT, tMm)
Dim dir As String = System.IO.Path.GetDirectoryName(docPath)
Dim baseName As String = System.IO.Path.GetFileNameWithoutExtension(docPath)
Dim stamp As String = DateTime.Now.ToString("yyyy-MM-dd_HH-mm-ss", System.Globalization.CultureInfo.InvariantCulture)
Dim fileName As String = baseName & "_" & SafeFilePart(mat) & "_" & SafeFilePart(thk) & "_" & stamp & ".txt"
Return System.IO.Path.Combine(dir, fileName)
Catch
Return ""
End Try
End Function
Function SafeFilePart(value As String) As String
' Strip characters illegal in Windows file names.
If String.IsNullOrWhiteSpace(value) OrElse value = UndefLabel() Then Return "unknown"
Dim s As String = value.Trim()
Dim bad As String = "\:*?""<>|/"
Dim i As Integer
For i = 1 To bad.Length
s = s.Replace(bad.Substring(i - 1, 1), "_")
Next
s = System.Text.RegularExpressions.Regex.Replace(s, "\s+", "_")
If IsBlank(s) Then s = "unknown"
Return s
End Function
Function WriteTextFile(path As String, content As String) As Boolean
Try
System.IO.File.WriteAllText(path, content, System.Text.Encoding.UTF8)
Return True
Catch
Return False
End Try
End Function