Erika Ahlswede

On-Rebuild macro working when added to existing part but not to template

Discussion created by Erika Ahlswede on Aug 28, 2019
Latest reply on Aug 30, 2019 by Erika Ahlswede

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

Outcomes