Расчет цены листовых материалов

'==============================================================================
' SheetMetalCalc.bas — SolidWorks VBA macro
' Mirrors "Preliminary Cost Estimate" panel (Solidworks panel add-in).
'
' WHAT THIS MACRO DOES
'   For the active sheet-metal Part:
'     - reads part / thickness / material / weight
'     - temporarily flattens FlatPattern
'     - measures area, blank (+ allowance), laser path, bend count / length
'     - checks flat-body geometry (Body.Check2)
'     - computes material / cut / bend / engraver / total price
'   Shows the same text report as the panel (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 below (prices, allowance, export flags).
'   2) Open a saved sheet-metal Part in SolidWorks.
'   3) Tools > Macro > Run > select this .bas (entry point: main).
'
' NOTES
'   - Late binding (Object) — no SolidWorks type library required.
'   - FlatPattern is restored to the previous suppressed/unsuppressed state.
'   - Settings mirror CostSettingsData defaults from the panel add-in.
'==============================================================================

Option Explicit

'----- SETTINGS (edit these — same meaning as panel Cost Settings) ------------
' Values below match a typical panel preset; dump of these is appended to report
' under "Settings" so a .txt export can restore the calculation inputs later.

Private Const iDecimalPlaces As Integer = 2
' Places after decimal for geometry values (price always 2). Panel: Decimal places.

Private Const dMaterialAllowanceMm As Double = 1#
' Blank allowance per side, mm. Panel: Material allowance (mm).

Private Const dPricePerBend As Double = 2#
' Price for one bend. Panel: Price per 1 bend.

Private Const dPricePerMmBendLineEngraver As Double = 0.1
' Price per 1 mm of bend-line engraver path. Panel: Price per 1 mm bend line.

Private Const dPricePerMmCutPer1MmThickness As Double = 13.55
' Cut price per 1 mm path at 1 mm thickness. Panel: Price per 1 mm cut.

Private Const dMaterialPrice As Double = 12#
' Material unit price. Panel: Material price.

Private Const bMaterialPricePerKg As Boolean = True
' True = Per 1 kg; False = Per 1 m?. Panel: Material price unit.

Private Const bMaterialNet As Boolean = False
' True = Area (Net); False = Blank (Gross). Panel: Material quantity.

Private Const bExportTxt As Boolean = True
' True = write report .txt next to the part file.

Private Const iNotify As Integer = 1
' 0 = MsgBox only on failure; 1 = always show report MsgBox.

'----- SW API constants -------------------------------------------------------
Private Const swDocPART As Long = 1
Private Const swUnSuppressFeature As Long = 2
Private Const swSuppressFeature As Long = 0
Private Const swThisConfiguration As Long = 1
Private Const swSketchLINE As Long = 0
Private Const API_TO_MM As Double = 1000#

Private Const KEY_COL As Integer = 12
Private Const SETTINGS_KEY_COL As Integer = 24
Private Const MODULE_SEP As String = "---"
Private Const UNDEF As String = "undefined"

'----- Module state -----------------------------------------------------------
Private swApp As Object
Private swModel As Object

'==============================================================================
' ENTRY
'==============================================================================
Public Sub main()
    Dim report As String
    Dim path As String
    Dim ok As Boolean

    On Error GoTo Fatal
    Set swApp = Application.SldWorks
    If swApp Is Nothing Then Set swApp = GetObject(, "SldWorks.Application")
    If swApp Is Nothing Then
        MsgBox "SolidWorks is not running.", vbExclamation, "SheetMetalCalc"
        Exit Sub
    End If

    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then
        MsgBox "No document open.", vbExclamation, "SheetMetalCalc"
        Exit Sub
    End If

    report = BuildReport()
    ok = (Len(report) > 0) And (InStr(1, report, "No document", vbTextCompare) = 0)

    If bExportTxt And ok And CanWriteNextToModel() Then
        path = BuildTxtPath()
        If Len(path) > 0 Then
            If WriteTextFile(path, report) Then
                report = report & vbCrLf & MODULE_SEP & vbCrLf & _
                         PadKey("export") & " - " & path
            Else
                report = report & vbCrLf & MODULE_SEP & vbCrLf & _
                         "Export failed: could not write TXT."
                ok = False
            End If
        End If
    End If

    If iNotify = 1 Or Not ok Then
        MsgBox report, IIf(ok, vbInformation, vbExclamation), "SheetMetalCalc"
    End If
    Exit Sub

Fatal:
    MsgBox "SheetMetalCalc error: " & Err.Description, vbCritical, "SheetMetalCalc"
End Sub

'==============================================================================
' REPORT (panel-compatible layout)
'==============================================================================
Private Function BuildReport() As String
    Dim modules As String
    Dim infoPart As String, infoThk As String, infoMat As String, infoW As String
    Dim isSm As Boolean
    Dim canMsg As String
    Dim areaMm2 As Double, blankL As Double, blankW As Double, blankA As Double
    Dim laserMm As Double, bendLenMm As Double
    Dim bendCnt As Long
    Dim hasArea As Boolean, hasBlank As Boolean, hasLaser As Boolean
    Dim hasBendCnt As Boolean, hasBendLen As Boolean
    Dim hasOverlap As Boolean, overlapMsg As String
    Dim weightKg As Double, thkMm As Double
    Dim hasWeight As Boolean, hasThk As Boolean
    Dim matCost As Variant, cutCost As Variant, bendCost As Variant, engCost As Variant
    Dim totalTxt As String
    Dim sheetBlock As String
    Dim engBlock As String

    GetPartInfo isSm, infoPart, infoThk, infoMat, infoW, hasWeight, weightKg, hasThk, thkMm

    If Not isSm Then
        BuildReport = "Document is not a sheet part." & vbCrLf & _
                      "(Open a part with Flat Pattern / sheet metal.)" & _
                      vbCrLf & MODULE_SEP & vbCrLf & BuildSettingsBlock()
        Exit Function
    End If

    If Not CanFlatten(canMsg) Then
        BuildReport = PadKey("part") & " - " & infoPart & " loaded" & vbCrLf & _
                      PadKey("thickness") & " - " & infoThk & vbCrLf & _
                      PadKey("material") & " - " & infoMat & vbCrLf & _
                      IIf(hasWeight, PadKey("weight") & " - " & infoW & vbCrLf, "") & _
                      PadKey("price") & " - (not calculated)" & vbCrLf & _
                      MODULE_SEP & vbCrLf & canMsg & _
                      vbCrLf & MODULE_SEP & vbCrLf & BuildSettingsBlock()
        Exit Function
    End If

    If Not CalcOnFlatPattern(areaMm2, hasArea, blankL, blankW, blankA, hasBlank, _
                             laserMm, hasLaser, bendCnt, hasBendCnt, bendLenMm, hasBendLen, _
                             hasOverlap, overlapMsg) Then
        BuildReport = PadKey("part") & " - " & infoPart & " loaded" & vbCrLf & _
                      PadKey("thickness") & " - " & infoThk & vbCrLf & _
                      PadKey("material") & " - " & infoMat & vbCrLf & _
                      IIf(hasWeight, PadKey("weight") & " - " & infoW & vbCrLf, "") & _
                      PadKey("price") & " - (not calculated)" & vbCrLf & _
                      MODULE_SEP & vbCrLf & _
                      "Cannot flatten this part: Flat-Pattern/Flatten operation is unavailable." & _
                      vbCrLf & MODULE_SEP & vbCrLf & BuildSettingsBlock()
        Exit Function
    End If

    If hasOverlap Then
        BuildReport = PadKey("part") & " - " & infoPart & " loaded" & vbCrLf & _
                      PadKey("thickness") & " - " & infoThk & vbCrLf & _
                      PadKey("material") & " - " & infoMat & vbCrLf & _
                      IIf(hasWeight, PadKey("weight") & " - " & infoW & vbCrLf, "") & _
                      PadKey("price") & " - (not calculated)" & vbCrLf & _
                      MODULE_SEP & vbCrLf & _
                      IIf(Len(overlapMsg) > 0, overlapMsg, "Geometry check found issues in flat pattern.") & _
                      vbCrLf & MODULE_SEP & vbCrLf & BuildSettingsBlock()
        Exit Function
    End If

    If hasBendCnt And bendCnt <= 0 Then
        bendLenMm = 0#
        hasBendLen = True
    End If

    matCost = CalcMaterialCost(hasWeight, weightKg, hasArea, areaMm2, hasBlank, blankA, hasThk, thkMm)
    cutCost = CalcCutCost(hasLaser, laserMm, hasThk, thkMm)
    bendCost = CalcBendCost(hasBendCnt, bendCnt)
    engCost = CalcEngraverCost(hasBendLen, bendLenMm)
    totalTxt = FormatTotalPrice(matCost, cutCost, bendCost, engCost)

    ' Module 1 — part summary
    modules = PadKey("part") & " - " & infoPart & " loaded" & vbCrLf & _
              PadKey("thickness") & " - " & infoThk & vbCrLf & _
              PadKey("material") & " - " & infoMat & vbCrLf
    If hasWeight Then modules = modules & PadKey("weight") & " - " & infoW & vbCrLf
    modules = modules & PadKey("price") & " - " & totalTxt

    ' Module 2 — sheet / laser / bends
    sheetBlock = "Sheet OK" & vbCrLf
    If hasArea Then
        sheetBlock = sheetBlock & PadKey("area") & " - " & FmtNum(areaMm2, iDecimalPlaces) & " mm?" & vbCrLf
    End If
    If hasBlank Then
        sheetBlock = sheetBlock & PadKey("blank") & " - " & _
                     FmtNum(blankL, iDecimalPlaces) & " x " & FmtNum(blankW, iDecimalPlaces) & " mm (" & _
                     FmtNum(blankA, iDecimalPlaces) & " mm?), allowance +" & _
                     FmtNumG(dMaterialAllowanceMm) & " mm per side (from settings)" & vbCrLf
    End If
    sheetBlock = sheetBlock & PadKey("material price") & " - " & FormatMoney(matCost) & vbCrLf
    sheetBlock = sheetBlock & MODULE_SEP & vbCrLf & "Laser cut" & vbCrLf
    If hasLaser Then
        sheetBlock = sheetBlock & PadKey("length") & " - " & FmtNum(laserMm, iDecimalPlaces) & " mm" & vbCrLf
        sheetBlock = sheetBlock & PadKey("cutting price") & " - " & FormatMoney(cutCost) & vbCrLf
    Else
        sheetBlock = sheetBlock & PadKey("length") & " - —" & vbCrLf
        sheetBlock = sheetBlock & PadKey("cutting price") & " - (not calculated)" & vbCrLf
    End If
    sheetBlock = sheetBlock & MODULE_SEP & vbCrLf & "Bends" & vbCrLf
    sheetBlock = sheetBlock & PadKey("count") & " - " & CStr(IIf(hasBendCnt, bendCnt, 0)) & vbCrLf
    sheetBlock = sheetBlock & PadKey("bending price") & " - " & FormatMoney(bendCost)

    modules = modules & vbCrLf & MODULE_SEP & vbCrLf & sheetBlock

    ' Module 3 — engraver
    engBlock = "Engraver" & vbCrLf
    If hasBendLen Then
        engBlock = engBlock & PadKey("length") & " - " & FmtNum(bendLenMm, iDecimalPlaces) & " mm" & vbCrLf
    Else
        engBlock = engBlock & PadKey("length") & " - —" & vbCrLf
    End If
    engBlock = engBlock & PadKey("rate") & " - " & FmtNumG(dPricePerMmBendLineEngraver) & vbCrLf
    engBlock = engBlock & PadKey("price") & " - " & FormatMoney(engCost)
    modules = modules & vbCrLf & MODULE_SEP & vbCrLf & engBlock

    ' Module 4 — settings snapshot (for restore from TXT)
    modules = modules & vbCrLf & MODULE_SEP & vbCrLf & BuildSettingsBlock()

    BuildReport = modules
End Function

Private Function BuildSettingsBlock() As String
    Dim s As String
    s = "Settings" & vbCrLf
    s = s & PadSettingsKey("decimal places") & " - " & CStr(ClampDec(iDecimalPlaces)) & vbCrLf
    s = s & PadSettingsKey("material allowance") & " - " & FmtNumG(dMaterialAllowanceMm) & " mm" & vbCrLf
    s = s & PadSettingsKey("price per bend") & " - " & FmtNumG(dPricePerBend) & vbCrLf
    s = s & PadSettingsKey("price per mm engraver") & " - " & FmtNumG(dPricePerMmBendLineEngraver) & vbCrLf
    s = s & PadSettingsKey("price per mm cut") & " - " & FmtNumG(dPricePerMmCutPer1MmThickness) & vbCrLf
    s = s & PadSettingsKey("material price") & " - " & FmtNumG(dMaterialPrice) & vbCrLf
    s = s & PadSettingsKey("material price unit") & " - " & IIf(bMaterialPricePerKg, "Per 1 kg", "Per 1 m2") & vbCrLf
    s = s & PadSettingsKey("material quantity") & " - " & IIf(bMaterialNet, "Area", "Blank")
    BuildSettingsBlock = s
End Function

Private Function PadKey(ByVal key As String) As String
    If Len(key) >= KEY_COL Then
        PadKey = key
    Else
        PadKey = key & Space$(KEY_COL - Len(key))
    End If
End Function

Private Function PadSettingsKey(ByVal key As String) As String
    If Len(key) >= SETTINGS_KEY_COL Then
        PadSettingsKey = key
    Else
        PadSettingsKey = key & Space$(SETTINGS_KEY_COL - Len(key))
    End If
End Function

' Invariant decimal point (panel uses "."); avoids locale commas in MsgBox/TXT.
Private Function FmtNum(ByVal v As Double, ByVal dec As Integer) As String
    Dim n As Integer
    Dim s As String
    n = ClampDec(dec)
    If n = 0 Then
        s = Format$(v, "0")
    Else
        s = Format$(v, "0." & String$(n, "0"))
    End If
    FmtNum = Replace(Replace(s, " ", ""), ",", ".")
End Function

Private Function FmtNumG(ByVal v As Double) As String
    Dim s As String
    s = Trim$(Str$(v)) ' Str always uses "." as decimal separator
    FmtNumG = s
End Function

Private Function FormatMoney(ByVal v As Variant) As String
    If IsEmpty(v) Or IsNull(v) Then
        FormatMoney = "(not calculated)"
    Else
        FormatMoney = FmtNum(CDbl(v), 2)
    End If
End Function

Private Function ClampDec(ByVal n As Integer) As Integer
    If n < 0 Then
        ClampDec = 0
    ElseIf n > 10 Then
        ClampDec = 10
    Else
        ClampDec = n
    End If
End Function

'==============================================================================
' PART INFO
'==============================================================================
Private Sub GetPartInfo(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)
    Dim feat As Object
    Dim smData As Object
    Dim hasFlat As Boolean
    Dim thkM As Double
    Dim hasThkM As Boolean
    Dim database As String
    Dim matName As String
    Dim ext As Object
    Dim massProp As Object
    Dim mass As Double

    isSm = False
    partName = UNDEF
    thickness = UNDEF
    material = UNDEF
    weight = UNDEF
    hasWeight = False
    weightKg = 0#
    hasThk = False
    thkMm = 0#
    hasFlat = False
    hasThkM = False

    On Error Resume Next
    partName = swModel.GetTitle
    If Len(partName) = 0 Then partName = UNDEF

    If swModel.GetType <> swDocPART Then Exit Sub

    Set feat = swModel.FirstFeature
    Do While Not feat Is Nothing
        If StrComp(feat.GetTypeName2, "FlatPattern", vbTextCompare) = 0 Then hasFlat = True
        If StrComp(feat.GetTypeName2, "SheetMetal", vbTextCompare) = 0 Then
            Set smData = feat.GetDefinition
            If Not smData Is Nothing Then
                thkM = smData.thickness
                hasThkM = True
            End If
        End If
        Set feat = feat.GetNextFeature
    Loop

    isSm = hasFlat
    If hasThkM Then
        thkMm = thkM * API_TO_MM
        hasThk = (thkMm > 0)
        thickness = FmtNum(thkMm, iDecimalPlaces) & " mm"
    End If

    matName = ""
    database = ""
    matName = swModel.GetMaterialPropertyName2("", database)
    If Len(Trim$(matName)) > 0 Then material = matName

    If material <> UNDEF Then
        Set ext = swModel.Extension
        If Not ext Is Nothing Then
            Set massProp = ext.CreateMassProperty
            If Not massProp Is Nothing Then
                mass = massProp.mass
                If Err.Number = 0 And mass >= 0 Then
                    hasWeight = True
                    weightKg = mass
                    weight = FmtNum(mass, iDecimalPlaces) & " kg"
                End If
                Err.Clear
            End If
        End If
    End If
    On Error GoTo 0
End Sub

'==============================================================================
' FLATTEN / GEOMETRY
'==============================================================================
Private Function CanFlatten(ByRef msg As String) As Boolean
    Dim flatFeat As Object
    Dim wasSuppressed As Boolean
    Dim flatBody As Object
    Dim ok As Boolean

    CanFlatten = False
    msg = ""

    If swModel.GetType <> swDocPART Then
        msg = "Active document is not a part."
        Exit Function
    End If

    Set flatFeat = GetFlatPatternFeature()
    If flatFeat Is Nothing Then
        msg = "Part is not sheet metal or has no flat pattern."
        Exit Function
    End If

    If Not TryGetSuppressed(flatFeat, wasSuppressed) Then
        msg = "Cannot check Flat Pattern state."
        Exit Function
    End If

    On Error GoTo Fail
    If wasSuppressed Then
        ok = flatFeat.SetSuppression2(swUnSuppressFeature, swThisConfiguration, Empty)
        If Not ok Then
            msg = "Cannot flatten this part: Flat-Pattern/Flatten operation is unavailable."
            Exit Function
        End If
        swModel.ForceRebuild3 False
        If Not TryGetSuppressed(flatFeat, ok) Or ok Then
            FoldBack flatFeat, wasSuppressed
            msg = "Cannot flatten this part: Flat-Pattern stayed folded after flatten command."
            Exit Function
        End If
    End If

    Set flatBody = GetFlatPatternBody()
    FoldBack flatFeat, wasSuppressed

    If flatBody Is Nothing Then
        msg = "Cannot flatten this part: Flat pattern body is unavailable."
        Exit Function
    End If

    CanFlatten = True
    msg = "Flat pattern is available."
    Exit Function

Fail:
    FoldBack flatFeat, wasSuppressed
    msg = "Cannot flatten this part: an error occurred while preparing Flat Pattern."
    CanFlatten = False
End Function

Private Function CalcOnFlatPattern(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 Long, ByRef hasBendCnt As Boolean, _
                                   ByRef bendLenMm As Double, ByRef hasBendLen As Boolean, _
                                   ByRef hasOverlap As Boolean, ByRef overlapMsg As String) As Boolean
    Dim flatFeat As Object
    Dim wasSuppressed As Boolean
    Dim flatBody As Object
    Dim ok As Boolean
    Dim checkRes As Long

    CalcOnFlatPattern = False
    hasArea = False: hasBlank = False: hasLaser = False
    hasBendCnt = False: hasBendLen = False
    hasOverlap = False
    overlapMsg = ""

    Set flatFeat = GetFlatPatternFeature()
    If flatFeat Is Nothing Then Exit Function
    If Not TryGetSuppressed(flatFeat, wasSuppressed) Then Exit Function

    On Error GoTo Fail
    If wasSuppressed Then
        ok = flatFeat.SetSuppression2(swUnSuppressFeature, swThisConfiguration, Empty)
        If Not ok Then Exit Function
        swModel.ForceRebuild3 False
        If Not TryGetSuppressed(flatFeat, ok) Or ok Then
            FoldBack flatFeat, wasSuppressed
            Exit Function
        End If
    End If

    Set flatBody = GetFlatPatternBody()
    If flatBody Is Nothing Then
        FoldBack flatFeat, wasSuppressed
        Exit Function
    End If

    ' Tools > Evaluate > Check equivalent
    On Error Resume Next
    Err.Clear
    checkRes = flatBody.Check2
    If Err.Number <> 0 Then
        Err.Clear
        overlapMsg = "Check could not be run."
        hasOverlap = False
    ElseIf checkRes <> 0 Then
        hasOverlap = True
        overlapMsg = "Geometry check found issues (Tools > Evaluate > Check). Fix errors in the flat pattern."
        FoldBack flatFeat, wasSuppressed
        CalcOnFlatPattern = True
        Exit Function
    Else
        hasOverlap = False
        overlapMsg = "No overlaps detected in the flat sheet (Check passed)."
    End If
    On Error GoTo Fail

    hasArea = TryPlanarAreaMm2(flatBody, areaMm2)
    hasBlank = TryBlankArea(flatBody, blankL, blankW, blankA)
    hasLaser = TryLaserPathMm(flatBody, laserMm)
    hasBendCnt = True
    bendCnt = GetBendLinesCount()
    hasBendLen = True
    bendLenMm = GetBendLinesLengthMm(IIf(hasLaser, laserMm, -1#), hasLaser)

    FoldBack flatFeat, wasSuppressed
    CalcOnFlatPattern = True
    Exit Function

Fail:
    FoldBack flatFeat, wasSuppressed
    CalcOnFlatPattern = False
End Function

Private Sub FoldBack(ByVal flatFeat As Object, ByVal wasSuppressed As Boolean)
    On Error Resume Next
    If wasSuppressed And Not flatFeat Is Nothing Then
        flatFeat.SetSuppression2 swSuppressFeature, swThisConfiguration, Empty
    End If
    Err.Clear
End Sub

Private Function TryGetSuppressed(ByVal feat As Object, ByRef isSuppressed As Boolean) As Boolean
    Dim v As Variant
    On Error Resume Next
    Err.Clear
    v = feat.IsSuppressed2(swThisConfiguration, Empty)
    If Err.Number <> 0 Then
        Err.Clear
        TryGetSuppressed = False
        Exit Function
    End If
    If IsArray(v) Then
        isSuppressed = CBool(v(0))
        TryGetSuppressed = True
    Else
        isSuppressed = CBool(v)
        TryGetSuppressed = True
    End If
End Function

Private Function GetFlatPatternFeature() As Object
    Dim feat As Object
    Set GetFlatPatternFeature = Nothing
    On Error Resume Next
    Set feat = swModel.FirstFeature
    Do While Not feat Is Nothing
        If StrComp(feat.GetTypeName2, "FlatPattern", vbTextCompare) = 0 Then
            Set GetFlatPatternFeature = feat
            Exit Function
        End If
        Set feat = feat.GetNextFeature
    Loop
End Function

Private Function GetFlatPatternBody() As Object
    Dim feat As Object
    Dim fpData As Object
    Dim fixedFace As Object
    Set GetFlatPatternBody = Nothing
    On Error Resume Next
    Set feat = GetFlatPatternFeature()
    If feat Is Nothing Then Exit Function
    Set fpData = feat.GetDefinition
    If fpData Is Nothing Then Exit Function
    Set fixedFace = fpData.FixedFace2
    If fixedFace Is Nothing Then Exit Function
    Set GetFlatPatternBody = fixedFace.GetBody
End Function

Private Function TryPlanarAreaMm2(ByVal body As Object, ByRef areaMm2 As Double) As Boolean
    Dim faces As Variant
    Dim i As Long
    Dim face As Object
    Dim a As Double, maxA As Double

    TryPlanarAreaMm2 = False
    On Error Resume Next
    faces = body.GetFaces
    If Err.Number <> 0 Or IsEmpty(faces) Then
        Err.Clear
        Exit Function
    End If
    maxA = 0#
    For i = 0 To UBound(faces)
        Set face = faces(i)
        If Not face Is Nothing Then
            a = face.GetArea
            If a > maxA Then maxA = a
        End If
    Next i
    If maxA <= 0 Then Exit Function
    areaMm2 = maxA * 1000000#
    TryPlanarAreaMm2 = True
End Function

Private Function TryBlankArea(ByVal body As Object, ByRef lengthMm As Double, _
                              ByRef widthMm As Double, ByRef areaMm2 As Double) As Boolean
    Dim boxObj As Variant
    Dim box() As Double
    Dim dx As Double, dy As Double, dz As Double
    Dim d(0 To 2) As Double
    Dim allow As Double

    TryBlankArea = False
    allow = dMaterialAllowanceMm
    On Error Resume Next
    boxObj = body.GetBodyBox
    If Err.Number <> 0 Or IsEmpty(boxObj) Then
        Err.Clear
        Exit Function
    End If
    If Not IsArray(boxObj) Then Exit Function
    If UBound(boxObj) < 5 Then Exit Function

    dx = (CDbl(boxObj(3)) - CDbl(boxObj(0))) * API_TO_MM
    dy = (CDbl(boxObj(4)) - CDbl(boxObj(1))) * API_TO_MM
    dz = (CDbl(boxObj(5)) - CDbl(boxObj(2))) * API_TO_MM

    If dz > dx Or dz > dy Then
        d(0) = dx: d(1) = dy: d(2) = dz
        Sort3 d
        lengthMm = d(2) + 2# * allow
        widthMm = d(1) + 2# * allow
    Else
        If dx >= dy Then
            lengthMm = dx + 2# * allow
            widthMm = dy + 2# * allow
        Else
            lengthMm = dy + 2# * allow
            widthMm = dx + 2# * allow
        End If
    End If
    areaMm2 = lengthMm * widthMm
    TryBlankArea = True
End Function

Private Sub Sort3(ByRef d() As Double)
    Dim t As Double
    If d(0) > d(1) Then t = d(0): d(0) = d(1): d(1) = t
    If d(1) > d(2) Then t = d(1): d(1) = d(2): d(2) = t
    If d(0) > d(1) Then t = d(0): d(0) = d(1): d(1) = t
End Sub

Private Function TryLaserPathMm(ByVal flatBody As Object, ByRef laserMm As Double) As Boolean
    Dim mainFace As Object
    Dim selMgr As Object
    Dim selData As Object
    Dim ext As Object
    Dim measure As Object
    Dim ok As Boolean
    Dim periM As Double
    Dim ent As Object

    TryLaserPathMm = False
    Set mainFace = GetMaxAreaFace(flatBody)
    If mainFace Is Nothing Then Exit Function

    On Error Resume Next
    swModel.ClearSelection2 True
    Set selMgr = swModel.SelectionManager
    If selMgr Is Nothing Then Exit Function
    Set selData = selMgr.CreateSelectData
    Set ent = mainFace
    ok = ent.Select4(False, selData)
    If Not ok Then
        swModel.ClearSelection2 True
        Exit Function
    End If

    Set ext = swModel.Extension
    If ext Is Nothing Then
        swModel.ClearSelection2 True
        Exit Function
    End If
    Set measure = ext.CreateMeasure
    If measure Is Nothing Then
        swModel.ClearSelection2 True
        Exit Function
    End If

    Err.Clear
    ok = measure.Calculate(Array(mainFace))
    swModel.ClearSelection2 True
    If Err.Number <> 0 Or Not ok Then
        Err.Clear
        Exit Function
    End If
    periM = measure.Perimeter
    If periM <= 0 Then Exit Function
    laserMm = periM * API_TO_MM
    TryLaserPathMm = True
End Function

Private Function GetMaxAreaFace(ByVal body As Object) As Object
    Dim faces As Variant
    Dim i As Long
    Dim face As Object
    Dim a As Double, maxA As Double
    Dim best As Object

    Set GetMaxAreaFace = Nothing
    On Error Resume Next
    faces = body.GetFaces
    If IsEmpty(faces) Then Exit Function
    maxA = 0#
    For i = 0 To UBound(faces)
        Set face = faces(i)
        If Not face Is Nothing Then
            a = face.GetArea
            If a > maxA Then
                maxA = a
                Set best = face
            End If
        End If
    Next i
    Set GetMaxAreaFace = best
End Function

'==============================================================================
' BEND LINES (same rules as SheetMetalCalcService)
'==============================================================================
Private Function GetBendLinesCount() As Long
    Dim flatFeat As Object
    Dim subFeat As Object
    Dim sketch As Object
    Dim total As Long
    Dim feat As Object
    Dim adjusted As Long

    total = 0
    On Error Resume Next
    Set flatFeat = GetFlatPatternFeature()
    If Not flatFeat Is Nothing Then
        Set subFeat = flatFeat.GetFirstSubFeature
        Do While Not subFeat Is Nothing
            Set sketch = Nothing
            Set sketch = subFeat.GetSpecificFeature2
            ' Late binding: any object with GetSketchSegments is treated as a sketch
            If Not sketch Is Nothing Then
                total = total + CountBendGroupsInSketch(sketch)
            End If
            Set subFeat = subFeat.GetNextSubFeature
        Loop
    End If

    If total = 0 Then
        Set feat = swModel.FirstFeature
        Do While Not feat Is Nothing
            If StrComp(feat.GetTypeName2, "SM3dBend", vbTextCompare) = 0 Then
                total = total + CountSketchedBend(feat)
            End If
            Set feat = feat.GetNextFeature
        Loop
    End If

    ' Panel subtracts 4 helper construction segments typical for flat-pattern sketches
    adjusted = total - 4
    If adjusted < 0 Then adjusted = 0
    GetBendLinesCount = adjusted
End Function

Private Function GetBendLinesLengthMm(ByVal laserMm As Double, ByVal hasLaser As Boolean) As Double
    Dim flatFeat As Object
    Dim subFeat As Object
    Dim sketch As Object
    Dim totalM As Double
    Dim feat As Object
    Dim totalMm As Double

    totalM = 0#
    On Error Resume Next
    Set flatFeat = GetFlatPatternFeature()
    If Not flatFeat Is Nothing Then
        Set subFeat = flatFeat.GetFirstSubFeature
        Do While Not subFeat Is Nothing
            Set sketch = subFeat.GetSpecificFeature2
            If Not sketch Is Nothing Then
                totalM = totalM + SketchConstructionLengthM(sketch)
            End If
            Set subFeat = subFeat.GetNextSubFeature
        Loop
    End If

    If totalM <= 0# Then
        Set feat = swModel.FirstFeature
        Do While Not feat Is Nothing
            If StrComp(feat.GetTypeName2, "SM3dBend", vbTextCompare) = 0 Then
                totalM = totalM + SketchedBendLengthM(feat)
            End If
            Set feat = feat.GetNextFeature
        Loop
    End If

    If totalM <= 0# Then
        GetBendLinesLengthMm = 0#
        Exit Function
    End If

    totalMm = totalM * API_TO_MM
    ' Subtract perimeter if construction sketches also contain cut contour
    If hasLaser And laserMm > 0 And totalMm > laserMm Then
        totalMm = totalMm - laserMm
    End If
    If totalMm < 0 Then totalMm = 0#
    GetBendLinesLengthMm = totalMm
End Function

Private Function CountSketchedBend(ByVal bendFeat As Object) As Long
    Dim subFeat As Object
    Dim sketch As Object
    CountSketchedBend = 0
    On Error Resume Next
    Set subFeat = bendFeat.GetFirstSubFeature
    Do While Not subFeat Is Nothing
        If StrComp(subFeat.GetTypeName2, "ProfileFeature", vbTextCompare) = 0 Then
            Set sketch = subFeat.GetSpecificFeature2
            If Not sketch Is Nothing Then
                CountSketchedBend = CountBendGroupsInSketch(sketch)
                Exit Function
            End If
        End If
        Set subFeat = subFeat.GetNextSubFeature
    Loop
End Function

Private Function SketchedBendLengthM(ByVal bendFeat As Object) As Double
    Dim subFeat As Object
    Dim sketch As Object
    SketchedBendLengthM = 0#
    On Error Resume Next
    Set subFeat = bendFeat.GetFirstSubFeature
    Do While Not subFeat Is Nothing
        If StrComp(subFeat.GetTypeName2, "ProfileFeature", vbTextCompare) = 0 Then
            Set sketch = subFeat.GetSpecificFeature2
            If Not sketch Is Nothing Then
                SketchedBendLengthM = SketchConstructionLengthM(sketch)
                Exit Function
            End If
        End If
        Set subFeat = subFeat.GetNextSubFeature
    Loop
End Function

Private Function SketchConstructionLengthM(ByVal sketch As Object) As Double
    Dim segs As Variant
    Dim i As Long
    Dim seg As Object
    Dim line As Object
    Dim sp As Object, ep As Object
    Dim dx As Double, dy As Double, dz As Double, ln As Double
    Dim sum As Double

    sum = 0#
    On Error Resume Next
    segs = sketch.GetSketchSegments
    If IsEmpty(segs) Then
        SketchConstructionLengthM = 0#
        Exit Function
    End If
    For i = 0 To UBound(segs)
        Set seg = segs(i)
        If Not seg Is Nothing Then
            If seg.GetType = swSketchLINE And seg.ConstructionGeometry Then
                Set line = seg
                Set sp = line.GetStartPoint2
                Set ep = line.GetEndPoint2
                If Not sp Is Nothing And Not ep Is Nothing Then
                    dx = ep.X - sp.X
                    dy = ep.Y - sp.Y
                    dz = ep.Z - sp.Z
                    ln = Sqr(dx * dx + dy * dy + dz * dz)
                    If ln > 0 Then sum = sum + ln
                End If
            End If
        End If
    Next i
    SketchConstructionLengthM = sum
End Function

' Group colinear connected construction lines into bend counts (BFS)
Private Function CountBendGroupsInSketch(ByVal sketch As Object) As Long
    Dim segs As Variant
    Dim n As Long, i As Long, j As Long, k As Long
    Dim seg As Object, line As Object, sp As Object, ep As Object
    Dim isLine() As Boolean
    Dim p1x() As Double, p1y() As Double, p1z() As Double
    Dim p2x() As Double, p2y() As Double, p2z() As Double
    Dim dx() As Double, dy() As Double, dz() As Double
    Dim visited() As Boolean
    Dim queue() As Long
    Dim qHead As Long, qTail As Long
    Dim groups As Long
    Dim vx As Double, vy As Double, vz As Double, ln As Double
    Dim dot As Double
    Dim tol As Double, cosTol As Double

    CountBendGroupsInSketch = 0
    tol = 0.000001
    cosTol = 0.9999

    On Error Resume Next
    segs = sketch.GetSketchSegments
    If IsEmpty(segs) Then Exit Function
    n = UBound(segs) - LBound(segs) + 1
    If n <= 0 Then Exit Function

    ReDim isLine(0 To n - 1)
    ReDim p1x(0 To n - 1): ReDim p1y(0 To n - 1): ReDim p1z(0 To n - 1)
    ReDim p2x(0 To n - 1): ReDim p2y(0 To n - 1): ReDim p2z(0 To n - 1)
    ReDim dx(0 To n - 1): ReDim dy(0 To n - 1): ReDim dz(0 To n - 1)
    ReDim visited(0 To n - 1)
    ReDim queue(0 To n - 1)

    For i = 0 To n - 1
        Set seg = segs(LBound(segs) + i)
        isLine(i) = False
        If Not seg Is Nothing Then
            If seg.GetType = swSketchLINE And seg.ConstructionGeometry Then
                Set line = seg
                Set sp = line.GetStartPoint2
                Set ep = line.GetEndPoint2
                If Not sp Is Nothing And Not ep Is Nothing Then
                    p1x(i) = sp.X: p1y(i) = sp.Y: p1z(i) = sp.Z
                    p2x(i) = ep.X: p2y(i) = ep.Y: p2z(i) = ep.Z
                    vx = p2x(i) - p1x(i)
                    vy = p2y(i) - p1y(i)
                    vz = p2z(i) - p1z(i)
                    ln = Sqr(vx * vx + vy * vy + vz * vz)
                    If ln > tol Then
                        dx(i) = vx / ln
                        dy(i) = vy / ln
                        dz(i) = vz / ln
                        isLine(i) = True
                    End If
                End If
            End If
        End If
    Next i

    groups = 0
    For i = 0 To n - 1
        If isLine(i) And Not visited(i) Then
            groups = groups + 1
            qHead = 0: qTail = 0
            visited(i) = True
            queue(qTail) = i: qTail = qTail + 1
            Do While qHead < qTail
                j = queue(qHead): qHead = qHead + 1
                For k = 0 To n - 1
                    If isLine(k) And Not visited(k) Then
                        If ShareEndpoint(p1x(j), p1y(j), p1z(j), p2x(j), p2y(j), p2z(j), _
                                         p1x(k), p1y(k), p1z(k), p2x(k), p2y(k), p2z(k), tol) Then
                            dot = dx(j) * dx(k) + dy(j) * dy(k) + dz(j) * dz(k)
                            If Abs(dot) >= cosTol Then
                                visited(k) = True
                                queue(qTail) = k: qTail = qTail + 1
                            End If
                        End If
                    End If
                Next k
            Loop
        End If
    Next i

    CountBendGroupsInSketch = groups
End Function

Private Function ShareEndpoint(ByVal a1x As Double, ByVal a1y As Double, ByVal a1z As Double, _
                               ByVal a2x As Double, ByVal a2y As Double, ByVal a2z As Double, _
                               ByVal b1x As Double, ByVal b1y As Double, ByVal b1z As Double, _
                               ByVal b2x As Double, ByVal b2y As Double, ByVal b2z As Double, _
                               ByVal tol As Double) As Boolean
    Dim t2 As Double
    t2 = tol * tol
    ShareEndpoint = (Dist2(a1x, a1y, a1z, b1x, b1y, b1z) <= t2) Or _
                    (Dist2(a1x, a1y, a1z, b2x, b2y, b2z) <= t2) Or _
                    (Dist2(a2x, a2y, a2z, b1x, b1y, b1z) <= t2) Or _
                    (Dist2(a2x, a2y, a2z, b2x, b2y, b2z) <= t2)
End Function

Private Function Dist2(ByVal x1 As Double, ByVal y1 As Double, ByVal z1 As Double, _
                       ByVal x2 As Double, ByVal y2 As Double, ByVal z2 As Double) As Double
    Dim dx As Double, dy As Double, dz As Double
    dx = x1 - x2: dy = y1 - y2: dz = z1 - z2
    Dist2 = dx * dx + dy * dy + dz * dz
End Function

'==============================================================================
' PRICING (same formulas as ExportTaskPaneControl)
'==============================================================================
Private Function CalcMaterialCost(ByVal hasWeight As Boolean, ByVal weightKg As Double, _
                                  ByVal hasArea As Boolean, ByVal areaMm2 As Double, _
                                  ByVal hasBlank As Boolean, ByVal blankAreaMm2 As Double, _
                                  ByVal hasThk As Boolean, ByVal thkMm As Double) As Variant
    Dim blankMass As Double
    CalcMaterialCost = Empty

    If bMaterialNet Then
        If bMaterialPricePerKg Then
            If hasWeight And weightKg >= 0 Then CalcMaterialCost = weightKg * dMaterialPrice
        Else
            If hasArea And areaMm2 > 0 Then CalcMaterialCost = (areaMm2 / 1000000#) * dMaterialPrice
        End If
    Else
        If bMaterialPricePerKg Then
            If hasBlank And blankAreaMm2 > 0 And hasArea And areaMm2 > 0 And hasWeight And weightKg >= 0 Then
                blankMass = weightKg * (blankAreaMm2 / areaMm2)
                CalcMaterialCost = blankMass * dMaterialPrice
            End If
        Else
            If hasBlank And blankAreaMm2 > 0 Then CalcMaterialCost = (blankAreaMm2 / 1000000#) * dMaterialPrice
        End If
    End If
End Function

Private Function CalcCutCost(ByVal hasLaser As Boolean, ByVal laserMm As Double, _
                             ByVal hasThk As Boolean, ByVal thkMm As Double) As Variant
    CalcCutCost = Empty
    If Not hasLaser Or laserMm <= 0 Then Exit Function
    If Not hasThk Or thkMm <= 0 Then Exit Function
    If dPricePerMmCutPer1MmThickness <= 0 Then Exit Function
    CalcCutCost = laserMm * thkMm * dPricePerMmCutPer1MmThickness
End Function

Private Function CalcBendCost(ByVal hasCnt As Boolean, ByVal cnt As Long) As Variant
    CalcBendCost = Empty
    If Not hasCnt Or cnt <= 0 Then Exit Function
    If dPricePerBend <= 0 Then Exit Function
    CalcBendCost = CDbl(cnt) * dPricePerBend
End Function

Private Function CalcEngraverCost(ByVal hasLen As Boolean, ByVal lenMm As Double) As Variant
    CalcEngraverCost = Empty
    If Not hasLen Or lenMm <= 0 Then Exit Function
    If dPricePerMmBendLineEngraver <= 0 Then Exit Function
    CalcEngraverCost = lenMm * dPricePerMmBendLineEngraver
End Function

Private Function FormatTotalPrice(ByVal matCost As Variant, ByVal cutCost As Variant, _
                                  ByVal bendCost As Variant, ByVal engCost As Variant) As String
    Dim total As Double
    Dim workOnly As Double

    workOnly = 0#
    If Not IsEmpty(cutCost) Then workOnly = workOnly + CDbl(cutCost)
    If Not IsEmpty(bendCost) Then workOnly = workOnly + CDbl(bendCost)
    If Not IsEmpty(engCost) Then workOnly = workOnly + CDbl(engCost)

    If IsEmpty(matCost) Then
        FormatTotalPrice = FmtNum(workOnly, 2) & " (work price, material excluded)"
        Exit Function
    End If

    total = CDbl(matCost) + workOnly
    FormatTotalPrice = FmtNum(total, 2)
End Function

'==============================================================================
' TXT EXPORT
'==============================================================================
Private Function CanWriteNextToModel() As Boolean
    Dim p As String
    On Error Resume Next
    p = swModel.GetPathName
    CanWriteNextToModel = (Len(p) > 0)
End Function

Private Function BuildTxtPath() As String
    Dim docPath As String
    Dim dir As String, baseName As String
    Dim material As String, thickness As String
    Dim stamp As String
    Dim isSm As Boolean, partName As String, thk As String, mat As String, w As String
    Dim hasW As Boolean, wKg As Double, hasT As Boolean, tMm As Double

    BuildTxtPath = ""
    On Error Resume Next
    docPath = swModel.GetPathName
    If Len(docPath) = 0 Then Exit Function

    GetPartInfo isSm, partName, thk, mat, w, hasW, wKg, hasT, tMm
    material = SafeFilePart(mat)
    thickness = SafeFilePart(thk)

    dir = Left$(docPath, InStrRev(docPath, "\") - 1)
    baseName = Mid$(docPath, InStrRev(docPath, "\") + 1)
    If InStrRev(baseName, ".") > 0 Then baseName = Left$(baseName, InStrRev(baseName, ".") - 1)

    stamp = Format$(Now, "yyyy-mm-dd_hh-nn-ss")
    BuildTxtPath = dir & "\" & baseName & "_" & material & "_" & thickness & "_" & stamp & ".txt"
End Function

Private Function SafeFilePart(ByVal value As String) As String
    Dim s As String
    Dim i As Long
    Dim ch As String
    Dim bad As String

    If Len(Trim$(value)) = 0 Or value = UNDEF Then
        SafeFilePart = "unknown"
        Exit Function
    End If
    s = Trim$(value)
    bad = "\:*?""<>|/"
    For i = 1 To Len(bad)
        ch = Mid$(bad, i, 1)
        s = Replace(s, ch, "_")
    Next i
    s = Replace(s, " ", "_")
    Do While InStr(s, "__") > 0
        s = Replace(s, "__", "_")
    Loop
    If Len(s) = 0 Then s = "unknown"
    SafeFilePart = s
End Function

Private Function WriteTextFile(ByVal path As String, ByVal content As String) As Boolean
    Dim fso As Object
    Dim ts As Object
    On Error GoTo Fail
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.CreateTextFile(path, True, True) ' Unicode
    ts.Write content
    ts.Close
    WriteTextFile = True
    Exit Function
Fail:
    WriteTextFile = False
End Function