AnsweredAssumed Answered

Macro to rename Cutlist Item, Configuration Specific

Question asked by Kevin Wilson on Oct 9, 2019
Latest reply on Oct 10, 2019 by Kevin Wilson

Hey all,

I'm very new to the macro world, but I'm trying to learn and was looking for a little help.  I've cobbled together a macro (mostly stuff posted here by Deepak Gupta that can rename Weldment cutlist items using "Filename-ConfiurationName-Counter".  Everything works well except the Configuration part.  The macro renames cutlist items in all configurations using whichever configuration is currently selected.  What I would like is a macro that runs on all configurations, but renames using each cutlist's specific configuration.  Here's my code...can you help, please?

Option Explicit

Dim SwApp As SldWorks.SldWorks

Dim swModel As SldWorks.ModelDoc2

Dim swConfig As SldWorks.ModelDoc2

Dim sModelName As String

Dim sConfigName As String

Dim Part As SldWorks.ModelDoc2

Dim swFeat As SldWorks.Feature

Dim boolstatus As Long

Dim foldercount As Integer

Dim prefixName As String


Sub Main()

'prefixName = InputBox("Enter a prefix for the cut-list folder names")

foldercount = 0

Set SwApp = CreateObject("SldWorks.Application")

Set Part = SwApp.ActiveDoc

Set swModel = SwApp.ActiveDoc

Set swConfig = SwApp.ActiveDoc

'File name with extension

sModelName = Mid(swModel.GetPathName, InStrRev(swModel.GetPathName, "\") + 1)

Debug.Print sModelName

'File name without extension

sModelName = Left(sModelName, InStrRev(sModelName, ".") - 1)

Debug.Print sModelName

'Read Configuration name and write it to variable string

sConfigName = swModel.GetActiveConfiguration.Name

Debug.Print sConfigName

'Label1.Text = String1.Substring(0, 5) & "-" & String1.Substring(5)

prefixName = sModelName & "-" & sConfigName & "-"

If Part Is Nothing Then

MsgBox ("A part must be opened")

Exit Sub

End If

If Part.GetType <> 1 Then

MsgBox ("A part must be opened")

Exit Sub

End If

Set swFeat = Part.FirstFeature

TraverseFeatures swFeat, True

Part.ClearSelection2 (True)

End Sub


Sub TraverseFeatures(ByVal thisFeat As Feature, ByVal isTopLevel As Boolean)

Dim curFeat As SldWorks.Feature

Set curFeat = thisFeat

While Not curFeat Is Nothing

If Not isTopLevel Then DoTheWork curFeat

Dim subfeat As SldWorks.Feature

Set subfeat = curFeat.GetFirstSubFeature

While Not subfeat Is Nothing

TraverseFeatures subfeat, False

Dim nextSubFeat As SldWorks.Feature

Set nextSubFeat = subfeat.GetNextSubFeature

Set subfeat = nextSubFeat

Set nextSubFeat = Nothing


Set subfeat = Nothing

Dim nextFeat As SldWorks.Feature

If isTopLevel Then

Set nextFeat = curFeat.GetNextFeature


Set nextFeat = Nothing

End If

Set curFeat = nextFeat

Set nextFeat = Nothing


End Sub


Sub DoTheWork(ByVal thisFeat As Feature)

If thisFeat.GetTypeName = "CutListFolder" Then

If thisFeat.GetSpecificFeature2.GetBodyCount = 0 Then Exit Sub

foldercount = foldercount + 1

boolstatus = Part.Extension.SelectByID2(thisFeat.Name, "SUBWELDFOLDER", 0, 0, 0, False, 0, Nothing, 0)

Part.SelectionManager.GetSelectedObject5(1).Name = prefixName & IIf(foldercount < 10, "00" + CStr(foldercount), IIf(foldercount < 100, "0" + CStr(foldercount), CStr(foldercount)))

End If

End Sub