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
You can use codes from this example: Flatten Sheet Metal Part Example (VBA)