7 Replies Latest reply on Jul 21, 2016 10:18 AM by Elmar Klammer

    Add custom property - Stocksize, Sort Dimensions macro

    JOHN GEORGE

      I tried to modify one of the bounding box macro from this forum and added few lines to sort the values in order (posted in another discussion)

      I have couple of issues with the result

      • It returns the message box result correct, but custom property values are different (shows only 0 x 0 x 0)
      • When I change my part units to fractions, it shows error in line "arr(1) = Length"

      Here is the full code

      Can someone please help me to solve the issue?

      Thanks!

       

       

      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

      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

          '---------------------------------------------------------------------------------
         MsgBox (arr(1) & " x " & arr(2) & " x " & arr(3))
         '---------------------------------------------------------------------------------

      End Sub

      Sub Main()

      Dim arr(1 To 3) As Double
      Dim swCustPropMgr As SldWorks.CustomPropertyManager
      Dim swModel As SldWorks.ModelDoc2
      Dim StockSize As String

      Set swApp = CreateObject("SldWorks.Application")
      Set Part = swApp.ActiveDoc
      Set swModel = swApp.ActiveDoc
      Set swCustProp = swModel.Extension.CustomPropertyManager("")

       

      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

      StockSize = (arr(1) & " x " & arr(2) & " x " & arr(3))   
        retval = Part.DeleteCustomInfo2("", "StockSize") 'Remove existing properties 
        swCustProp.Add3 "Stocksize", swCustomInfoText, StockSize, 1 'Add latest values
      End Sub

        • Re: Add custom property - Stocksize, Sort Dimensions macro
          Deepak Gupta

          Not sure why it is not working with fractions but for other than that, arr has not values in the main sub and hence you get 0 in the properties while the sub where you've the message, arr has values defined.

           

          Attached is updated/fixed version that works for normal unit settings.

          • Re: Add custom property - Stocksize, Sort Dimensions macro
            Elmar Klammer

            You can trouble shoot the error or you can add a few lines of code to set the units. Simply read the current unit settings, then change it to decimal. Get your boundary dimensions and last set the units back to the original settings. That should work.

            There is samples in this forum that show how to get/set units.

            On second thought just pass the stocksize to an array and split it before conversion. Code below worked for me with units set to fractions

             

            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
                '---------------------------------------------------------------------------------
               MsgBox (arr(1) & " x " & arr(2) & " x " & arr(3))
            StockSize = (arr(1) & " x " & arr(2) & " x " & arr(3))
              
            '
            'Set swCustProp = Part.Extension.CustomPropertyManager("")
            'retval = Part.DeleteCustomInfo2("", "StockSize") 'Remove existing properties
            ''swCustProp.Add3 "Stocksize", swCustomInfoText, StockSize, 1 'Add latest values
            'swCustProp.Add2 "Stocksize", swCustomInfoText, StockSize
            '   '---------------------------------------------------------------------------------
            End Sub
            Sub Main()
            Dim arr(1 To 3) As Double
            Dim strArray() As String
            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

            Call SortDimensions
            Debug.Print StockSize

            strArray = Split(StockSize, "x")
            Height = Trim(strArray(0))
            Width = Trim(strArray(1))
            Length = Trim(strArray(2))
            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

            StockSize = (Height & " x " & Width & " x " & Length)
            Debug.Print StockSize
            Set swCustProp = Part.Extension.CustomPropertyManager("")
            retval = Part.DeleteCustomInfo2("", "StockSize") 'Remove existing properties
            'swCustProp.Add3 "Stocksize", swCustomInfoText, StockSize, 1 'Add latest values
            swCustProp.Add2 "Stocksize", swCustomInfoText, StockSize

            End Sub