I'm trying to make a super-automated set of sheet metal custom properties. Basically, I want to get the bounding box length, width, area, and overall tool path length from the cut list properties and into the global properties so they can get nice fields on a drawing. I've had pretty good luck so far cribbing from code I've found online, but I've hit a stumbling block.
The macro I've come up with works perfectly well when I run it on an existing part, but when I apply it to the part template, and then build a new part based on that template, it does nothing.
This is the code I'm working with. Anyone have any idea what I'm doing wrong? Thanks!
Option Explicit
Const EMBED_MACRO_FEATURE As Boolean = True
Const BASE_NAME As String = "SheetMetalProperties"
Dim HandledModels As Collection
Sub main()
Dim swApp As SldWorks.SldWorks
Set swApp = Application.SldWorks
Dim swModel As SldWorks.ModelDoc2
Set swModel = swApp.ActiveDoc
If Not swModel Is Nothing Then
If swModel.GetType() = swDocumentTypes_e.swDocPART Then
Dim curMacroPath As String
curMacroPath = swApp.GetCurrentMacroPathName
Dim vMethods(8) As String
Dim moduleName As String
GetMacroEntryPoint swApp, curMacroPath, moduleName, ""
vMethods(0) = curMacroPath: vMethods(1) = moduleName: vMethods(2) = "swmRebuild"
vMethods(3) = curMacroPath: vMethods(4) = moduleName: vMethods(5) = "swmEditDefinition"
vMethods(6) = curMacroPath: vMethods(7) = moduleName: vMethods(8) = "swmSecurity"
Dim opts As swMacroFeatureOptions_e
If EMBED_MACRO_FEATURE Then
opts = swMacroFeatureOptions_e.swMacroFeatureEmbedMacroFile
Else
opts = swMacroFeatureOptions_e.swMacroFeatureByDefault
End If
Dim swFeat As SldWorks.Feature
Set swFeat = swModel.FeatureManager.InsertMacroFeature3(BASE_NAME, "", vMethods, _
Empty, Empty, Empty, Empty, Empty, Empty, _
Empty, opts)
If swFeat Is Nothing Then
MsgBox "Failed to create model load watcher"
End If
Else
MsgBox "This macro is only for Piece Parts"
End If
Else
MsgBox "Please open model"
End If
End Sub
Sub GetMacroEntryPoint(app As SldWorks.SldWorks, macroPath As String, ByRef moduleName As String, ByRef procName As String)
Dim vMethods As Variant
vMethods = app.GetMacroMethods(macroPath, swMacroMethods_e.swMethodsWithoutArguments)
Dim i As Integer
If Not IsEmpty(vMethods) Then
For i = 0 To UBound(vMethods)
Dim vData As Variant
vData = Split(vMethods(i), ".")
If i = 0 Or LCase(vData(1)) = "main" Then
moduleName = vData(0)
procName = vData(1)
End If
Next
End If
End Sub
Function swmRebuild(varApp As Variant, varDoc As Variant, varFeat As Variant) As Variant
Dim swFeat As SldWorks.Feature
Set swFeat = varFeat
Dim swModel As SldWorks.ModelDoc2
Set swModel = varDoc
If Not swModel Is Nothing Then
Dim swCutListFeat As SldWorks.Feature, swSMBaseFlangeFeat As SldWorks.Feature
Dim mainProps As SldWorks.CustomPropertyManager
Set mainProps = swModel.Extension.CustomPropertyManager("")
Set swCutListFeat = GetNextCutList(swModel, swModel.FirstFeature)
Do While Not swCutListFeat Is Nothing
Dim val As String, resolvedVal As String
Dim WasResolved As Boolean, LinkToProperty As Boolean
Dim result As Integer
Dim outerCut As Double, innerCut As Double, Length As Double, Width As Double, Area As Double
Dim cutProps As SldWorks.CustomPropertyManager
Set cutProps = swCutListFeat.CustomPropertyManager
result = cutProps.Get6("Bounding Box Length", False, val, resolvedVal, WasResolved, LinkToProperty)
If IsNumeric(resolvedVal) Then
Length = CDbl(resolvedVal)
result = mainProps.Add3("LENGTH", swCustomInfoText, "x " + DecimalToInches(Length, 16), swCustomPropertyDeleteAndAdd)
End If
result = cutProps.Get6("Bounding Box Width", False, val, resolvedVal, WasResolved, LinkToProperty)
If IsNumeric(resolvedVal) Then
Width = CDbl(resolvedVal)
result = mainProps.Add3("WIDTH", swCustomInfoText, "x " + DecimalToInches(Width, 16), swCustomPropertyDeleteAndAdd)
End If
result = cutProps.Get6("Bounding Box Area", False, val, resolvedVal, WasResolved, LinkToProperty)
If IsNumeric(resolvedVal) Then
Area = CDbl(resolvedVal) / 144
result = mainProps.Add3("SURFACE AREA AUTO", swCustomInfoText, CStr(Format(Area, "0.000")), swCustomPropertyDeleteAndAdd)
End If
result = cutProps.Get6("Cutting Length-Outer", False, val, resolvedVal, WasResolved, LinkToProperty)
If result <> swCustomInfoGetResult_NotPresent And IsNumeric(resolvedVal) Then
outerCut = CDbl(resolvedVal)
result = cutProps.Get6("Cutting Length-Inner", False, val, resolvedVal, WasResolved, LinkToProperty)
If result <> swCustomInfoGetResult_NotPresent And IsNumeric(resolvedVal) Then
innerCut = CDbl(resolvedVal)
result = mainProps.Add3("BURN PATH LENGTH", swCustomInfoText, Format(CStr(outerCut + innerCut), "0.000"), swCustomPropertyDeleteAndAdd)
End If
End If
Set swCutListFeat = GetNextCutList(swModel, swCutListFeat.GetNextFeature)
Loop
End If
End Function
Function swmEditDefinition(varApp As Variant, varDoc As Variant, varFeat As Variant) As Variant
swmEditDefinition = True
End Function
Function swmSecurity(varApp As Variant, varDoc As Variant, varFeat As Variant) As Variant
Dim swFeat As SldWorks.Feature
Set swFeat = varFeat
If HandledModels Is Nothing Then
Set HandledModels = New Collection
End If
Dim swModel As SldWorks.ModelDoc2
Set swModel = varDoc
If Not CollectionContains(HandledModels, swModel) Then
HandledModels.Add swModel
Dim swApp As SldWorks.SldWorks
Set swApp = varApp
ClearCache swApp
OnModelLoad swModel
End If
swmSecurity = SwConst.swMacroFeatureSecurityOptions_e.swMacroFeatureSecurityByDefault
End Function
Sub ClearCache(app As SldWorks.SldWorks)
If Not HandledModels Is Nothing Then
Dim vDocs As Variant
vDocs = app.GetDocuments
If Not IsEmpty(vDocs) Then
Dim i As Integer
For i = HandledModels.Count To 1 Step -1
Dim swModel As SldWorks.ModelDoc2
Set swModel = HandledModels(i)
If Not ArrayContains(vDocs, swModel) Then
HandledModels.Remove i
End If
Next
End If
End If
End Sub
Function CollectionContains(coll As Collection, model As SldWorks.ModelDoc2) As Boolean
Dim i As Integer
For i = 1 To coll.Count()
If coll(i) Is model Then
CollectionContains = True
Exit Function
End If
Next
CollectionContains = False
End Function
Function ArrayContains(arr As Variant, model As SldWorks.ModelDoc2) As Boolean
Dim i As Integer
If Not IsEmpty(arr) Then
For i = 0 To UBound(arr)
Dim thisModel As SldWorks.ModelDoc2
Set thisModel = arr(i)
If thisModel Is model Then
ArrayContains = True
Exit Function
End If
Next
End If
ArrayContains = False
End Function
Sub OnModelLoad(model As SldWorks.ModelDoc2)
Dim cpm As CustomPropertyManager
Dim exists As swCustomInfoGetResult_e
Dim results As swCustomInfoAddResult_e
Dim WasResolved As Boolean, LinkToProperty As Boolean
Dim val As String, valout As String
Set cpm = model.Extension.CustomPropertyManager("")
exists = cpm.Get6("DESIGN BY", False, val, valout, WasResolved, LinkToProperty)
If exists = swCustomInfoGetResult_NotPresent Then
results = cpm.Add3("DESIGN BY", swCustomInfoText, UCase(Environ("USERNAME")), swCustomPropertyOnlyIfNew)
End If
exists = cpm.Get6("DESIGN DATE", False, val, valout, WasResolved, LinkToProperty)
If exists = swCustomInfoGetResult_NotPresent Then
results = cpm.Add3("DESIGN DATE", swCustomInfoText, CStr(Format(Date, "mm/dd/yyyy")), swCustomPropertyOnlyIfNew)
End If
End Sub
Function GetNextCutList(model As SldWorks.ModelDoc2, swFeat As SldWorks.Feature) As SldWorks.Feature
On Error Resume Next
Dim swApp As SldWorks.SldWorks
Dim swBodyFolder As SldWorks.BodyFolder
Set swApp = Application.SldWorks
If swFeat Is Nothing Then Set swFeat = model.FirstFeature
Do While Not swFeat Is Nothing
If swFeat.GetTypeName = "SolidBodyFolder" Or swFeat.GetTypeName = "CutListFolder" Or swFeat.GetTypeName = "SubWeldFolder" Then
Set swBodyFolder = swFeat.GetSpecificFeature2
swBodyFolder.UpdateCutList
Set GetNextCutList = swFeat
Exit Function
End If
Set swFeat = swFeat.GetNextFeature
Loop
Set GetNextCutList = Nothing
End Function
Function DecimalToInches(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
remainder = DecimalLength
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
If (DecimalToInches <> "" Or intInches <> 0) Then
DecimalToInches = DecimalToInches & LTrim$(Str$(intInches))
If intFractions <> 0 Then
DecimalToInches = DecimalToInches & " "
End If
End If
If intFractions > 0 Then
DecimalToInches = DecimalToInches & LTrim$(Str$(intFractions))
DecimalToInches = DecimalToInches & "/" & LTrim$(Str$(Denominator))
End If
End Function
Function FractUp(InputFt As Integer, InputInch As Integer, InputNum As Integer, InputDenom As Integer)
'Debug.Print InputFt, InputInch, InputNum, InputDenom
' Simplify the fractions, Example: 6/8" becomes 3/4"
While InputNum Mod 2 = 0 And InputDenom Mod 2 = 0
InputNum = InputNum / 2
InputDenom = InputDenom / 2
Wend
' See if we now have a full inch or 12 inches. If so, bump stuff up
If InputDenom = 1 Then ' Full inch
InputInch = InputInch + 1
InputNum = 0
End If
'Debug.Print InputFt, InputInch, InputNum, InputDenom
End Function
It seemed to work OK for me. Attached is a 2018 template. Sometimes I need to use a Ctrl-Q rebuild to force the rebuild of the macro feature.