Stocksize MACRO

Hi,

I have a macro that can capture all bounding box dimensions and displays them in ascending order in custom properties. I started to use TASK and now i can run a macro on many parts without to manual open them and run macro.

Problem is that i work with sheet metal parts and that macro does not flatten sheet metal parts before it takes dimensions.

Does someone know how to modify that macro to check a part configuration and if it if a sheet metal first to flatten it and then to take dimensions.

MACRO:

Dim swApp As SldWorks.SldWorks

Dim Part As SldWorks.ModelDoc2

Dim Height As Variant

Dim Width As Variant

Dim Length As Variant

Dim Corners As Variant

Dim retval As Boolean

Dim UserUnits As Variant

Const swDocPart = 1

Const swDocASSEMBLY = 2

'Enum swLengthUnit_e

Const swMM = 0

Const swCM = 1

Const swMETER = 2

Const swINCHES = 3

Const swFEET = 4

Const swFEETINCHES = 5

Const swANGSTROM = 6

Const swNANOMETER = 7

Const swMICRON = 8

Const swMIL = 9

Const swUIN = 10

'Enum swFractionDisplay_e

Const swNONE = 0

Const swDECIMAL = 1

Const swFRACTION = 2

Dim swCustPropMgr As SldWorks.CustomPropertyManager

Dim swModel As SldWorks.ModelDoc2

Dim StockSize As String

Function DecimalToFeetInches(DecimalLength As Variant, Denominator As Integer) As String

  ' converts decimal inches to feet/inches/fractions

  Dim intFeet As Integer

  Dim intInches As Integer

  Dim intFractions As Integer

  Dim FractToDecimal As Double

  Dim remainder As Double

  Dim tmpVal As Double

  ' compute whole feet

  intFeet = Int(DecimalLength / 12)

  remainder = DecimalLength - (intFeet * 12)

  tmpVal = CDbl(Denominator)

  intInches = Int(remainder)

  remainder = remainder - intInches

  If Not (remainder = 0) Then

    If Not (Denominator = 0) Then

      FractToDecimal = 1 / tmpVal

        If FractToDecimal > 0 Then

          intFractions = Int(remainder / FractToDecimal)

          If (remainder / FractToDecimal) - intFractions > 0 Then

            intFractions = intFractions + 1

          End If

        End If

     End If

  End If

  Call FractUp(intFeet, intInches, intFractions, Denominator) ' Simplify up & down

  DecimalToFeetInches = LTrim$(Str$(intFeet)) & "'-"

  DecimalToFeetInches = DecimalToFeetInches & LTrim$(Str$(intInches))

  If intFractions > 0 Then

    DecimalToFeetInches = DecimalToFeetInches & " "

    DecimalToFeetInches = DecimalToFeetInches & LTrim$(Str$(intFractions))

    DecimalToFeetInches = DecimalToFeetInches & "/" & LTrim$(Str$(Denominator))

  End If

  DecimalToFeetInches = DecimalToFeetInches & Chr$(34)

End Function

Function FractUp(InputFt As Integer, InputInch As Integer, InputNum As Integer, InputDenom As Integer)

  While InputNum Mod 2 = 0 And InputDenom Mod 2 = 0

    InputNum = InputNum / 2

    InputDenom = InputDenom / 2

  Wend

  If InputDenom = 1 Then  ' Full inch

    InputInch = InputInch + 1

    InputNum = 0

    If InputInch = 12 Then  ' Full foot

      InputFt = InputFt + 1

      InputInch = 0

    End If

  End If

End Function

'---------------------------------------------------------------------------------

Sub SortDimensions()

    Dim arr(1 To 3) As Double

    arr(1) = Length

    arr(2) = Width

    arr(3) = Height

    SortArr arr

End Sub

Sub SortArr(arr() As Double)

    Dim i As Long

    Dim j As Long

    Dim tmp As String

    Dim p As String

    For i = LBound(arr) To UBound(arr) - 1

        For j = i + 1 To UBound(arr)

            If arr(i) > arr(j) Then

                tmp = arr(i)

                arr(i) = arr(j)

                arr(j) = tmp

            End If

        Next j

    Next i

    '---------------------------------------------------------------------------------

   Dimenzije = (arr(1) & "x" & arr(2) & "x" & arr(3))

Set swCustProp = Part.Extension.CustomPropertyManager("")

retval = Part.DeleteCustomInfo2("", "Dimenzije") 'Remove existing properties

swCustProp.Add3 "Dimenzije", swCustomInfoText, Dimenzije, 1 'Add latest values

   '---------------------------------------------------------------------------------

End Sub

Sub Main()

Dim arr(1 To 3) As Double

Set swApp = Application.SldWorks

Set Part = swApp.ActiveDoc

If Part Is Nothing Then     ' Did we get anything?

  MsgBox "You need to have a part or assy open at this point." & Chr$(13) & Chr$(10) _

          & Chr$(10) & "Open one and try again."

  Exit Sub

End If

If (Part.GetType = swDocPart) Then

  Corners = Part.GetPartBox(True)         ' True comes back as system units - meters

ElseIf Part.GetType = swDocASSEMBLY Then  ' Units will come back as meters

  Corners = Part.GetBox(0)

Else

  MsgBox "This macro is only useful with a part or assy." & Chr$(13) & Chr$(10) & "Open one of those and try again."

  Exit Sub

End If

UserUnits = Part.GetUnits()

Select Case Part.GetUnits(0)

  Case swMM

    ConvFactor = 1 * 1000

  Case swCM

    ConvFactor = 1 * 100

  Case swMETER

    ConvFactor = 1

  Case swINCHES

    ConvFactor = 1 / 0.0254

  Case swFEET

    ConvFactor = 1 / (0.0254 * 12)

  Case swFEETINCHES

    ConvFactor = 1 / 0.0254  ' Pass inches through

  Case swANGSTROM

    ConvFactor = 10000000000#

  Case swNANOMETER

    ConvFactor = 1000000000

  Case swMICRON

    ConvFactor = 1000000

  Case swMIL

    ConvFactor = (1 / 0.0254) * 1000

  Case swUIN

    ConvFactor = (1 / 0.0254) * 1000000

End Select

Height = Round((Abs(Corners(4) - Corners(1)) * ConvFactor), UserUnits(3)) ' Z axis

Width = Round((Abs(Corners(5) - Corners(2)) * ConvFactor), UserUnits(3))  ' Y axis

Length = Round((Abs(Corners(3) - Corners(0)) * ConvFactor), UserUnits(3)) ' X axis

' Check for either (Feet-Inches OR Inches) AND fractions.  If so, return Ft-In

If (UserUnits(0) = 5 Or UserUnits(0) = 3) And UserUnits(1) = 2 Then

  Height = DecimalToFeetInches(Height, Val(UserUnits(2)))

  Width = DecimalToFeetInches(Width, Val(UserUnits(2)))

  Length = DecimalToFeetInches(Length, Val(UserUnits(2)))

End If

Call SortDimensions

End Sub

Nice day

Antonio