Set the document title from a template using tokens for custom properties, configuration, file name, and a sequential number stored on disk. Handy when you need consistent part/assembly naming tied to metadata.

Supported tokens

• <$PRP:Name> — any custom property (config-specific first, then document level).
• <_ConfName_> — active configuration name.
• <_AssmFileName_> — document file name without extension (requires saved file).
• <NMB> — sequential number formatted by NMB_FORMAT.

Key settings

Const NMB_SRC_FILE_PATH As String = "E:\prt.txt"
Const NMB_FORMAT As String = "000"
Const OUT_NAME_TEMPLATE As String = "<NMB>-PRT-<$PRP:Type>-<_ConfName_>"

Macro (VBA)

Option Explicit

'The following placeholders are supported
' <_ConfName_> - name of the active configuration
' <_AssmFileName_> - name of the active document (assembly or part) without extension
' <$PRP:[PropertyName]> - any custom property on the model (configuration-specific checked first, then document level)
' <NMB> - sequential number formatted with NMB_FORMAT

Const NMB_SRC_FILE_PATH As String = "E:\prt.txt"
Const NMB_FORMAT As String = "000"
Const OUT_NAME_TEMPLATE As String = "<NMB>-PRT-<$PRP:Type>-<_ConfName_>"

Dim swApp As SldWorks.SldWorks

Sub main()
    
    Set swApp = Application.SldWorks
    
try_:
    On Error GoTo catch_
    
    Dim swModel As SldWorks.ModelDoc2
    Set swModel = swApp.ActiveDoc
    
    If swModel Is Nothing Then
        Err.Raise vbError, "", "Please open a part or assembly document"
    End If
    
    Dim confName As String
    confName = swModel.ConfigurationManager.ActiveConfiguration.Name
    
    Dim lastNumber As Long
    lastNumber = ReadNumber(NMB_SRC_FILE_PATH)
    
    Dim nextNumber As Long
    nextNumber = lastNumber + 1
    
    Dim newTitle As String
    newTitle = ComposeOutName(OUT_NAME_TEMPLATE, swModel, confName, nextNumber)
    
    If False = swModel.SetTitle2(newTitle) Then
        Err.Raise vbError, "", "Failed to set title"
    End If
    
    StoreNumber NMB_SRC_FILE_PATH, nextNumber
    
    swApp.SendMsgToUser2 "Set name to: " & newTitle, swMessageBoxIcon_e.swMbInformation, swMessageBoxBtn_e.swMbOk
    
    GoTo finally_
    
catch_:
    swApp.SendMsgToUser2 Err.Description, swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
finally_:
    
End Sub

Function ComposeOutName(template As String, model As SldWorks.ModelDoc2, conf As String, seqNumber As Long) As String
    
    Dim regEx As Object
    Set regEx = CreateObject("VBScript.RegExp")
    
    regEx.Global = True
    regEx.IgnoreCase = True
    regEx.Pattern = "<[^>]*>"
    
    Dim regExMatches As Object
    Set regExMatches = regEx.Execute(template)
    
    Dim i As Integer
    Dim resolved As String
    resolved = template
    
    For i = regExMatches.Count - 1 To 0 Step -1
        
        Dim regExMatch As Object
        Set regExMatch = regExMatches.Item(i)
        
        Dim tokenName As String
        tokenName = Mid(regExMatch.Value, 2, Len(regExMatch.Value) - 2)
        
        resolved = Left(resolved, regExMatch.FirstIndex) & ResolveToken(tokenName, model, conf, seqNumber) & Right(resolved, Len(resolved) - (regExMatch.FirstIndex + regExMatch.Length))
    Next
    
    ComposeOutName = ReplaceInvalidNameSymbols(resolved)
    
End Function

Function ResolveToken(token As String, model As SldWorks.ModelDoc2, conf As String, seqNumber As Long) As String
    
    Const CONF_NAME_TOKEN As String = "_ConfName_"
    Const ASSM_FILE_NAME_TOKEN As String = "_AssmFileName_"
    Const PRP_TOKEN As String = "$PRP:"
    Const NMB_TOKEN As String = "NMB"
    
    Select Case LCase(token)
        Case LCase(CONF_NAME_TOKEN)
            ResolveToken = conf
        Case LCase(ASSM_FILE_NAME_TOKEN)
            If model.GetPathName() = "" Then
                Err.Raise vbError, "", "Document must be saved to use " & ASSM_FILE_NAME_TOKEN
            End If
            ResolveToken = GetFileNameWithoutExtension(model.GetPathName())
        Case LCase(NMB_TOKEN)
            ResolveToken = Format(seqNumber, NMB_FORMAT)
        Case Else
            
            Dim prpName As String
            
            If Left(token, Len(PRP_TOKEN)) = PRP_TOKEN Then
                prpName = Right(token, Len(token) - Len(PRP_TOKEN))
                ResolveToken = GetModelPropertyValue(model, conf, prpName)
            Else
                Err.Raise vbError, "", "Unrecognized token: " & token
            End If
            
    End Select
    
End Function

Function ReplaceInvalidNameSymbols(value As String) As String
    
    Const REPLACE_SYMB As String = "_"
    
    Dim cleaned As String
    cleaned = value
    
    Dim invalidSymbols As Variant
    invalidSymbols = Array("/", ":", "*", "?", """", "<", ">", "|", "\")
    
    Dim i As Integer
    For i = 0 To UBound(invalidSymbols)
        cleaned = Replace(cleaned, CStr(invalidSymbols(i)), REPLACE_SYMB)
    Next
    
    ReplaceInvalidNameSymbols = cleaned
    
End Function

Function GetModelPropertyValue(model As SldWorks.ModelDoc2, confName As String, prpName As String) As String
    
    Dim prpVal As String
    Dim swCustPrpMgr As SldWorks.CustomPropertyManager
    
    Set swCustPrpMgr = model.Extension.CustomPropertyManager(confName)
    prpVal = GetPropertyValue(swCustPrpMgr, prpName)
    
    If prpVal = "" Then
        Set swCustPrpMgr = model.Extension.CustomPropertyManager("")
        prpVal = GetPropertyValue(swCustPrpMgr, prpName)
    End If
    
    GetModelPropertyValue = prpVal
    
End Function

Function GetPropertyValue(custPrpMgr As SldWorks.CustomPropertyManager, prpName As String) As String
    Dim resVal As String
    custPrpMgr.Get2 prpName, "", resVal
    GetPropertyValue = resVal
End Function

Function GetFileNameWithoutExtension(path As String) As String
    GetFileNameWithoutExtension = Mid(path, InStrRev(path, "\") + 1, InStrRev(path, ".") - InStrRev(path, "\") - 1)
End Function

Function ReadNumber(filePath As String) As Long
    
    If Dir(filePath) = "" Then
        ReadNumber = 0
        Exit Function
    End If
    
    Dim fileNo As Integer
    fileNo = FreeFile
    
    Dim number As String
    
    Open filePath For Input As #fileNo
    Line Input #fileNo, number
    Close #fileNo
    
    If number = "" Then
        ReadNumber = 0
    Else
        ReadNumber = CLng(number)
    End If
    
End Function

Sub StoreNumber(filePath As String, number As Long)
    
    Dim fileNo As Integer
    fileNo = FreeFile
    
    Open filePath For Output As #fileNo
    Print #fileNo, CStr(number)
    Close #fileNo
    
End Sub

Usage

1. Save the part/assembly so _AssmFileName_ resolves.
2. Ensure E:\prt.txt exists (or let the macro start at 000).
3. Set required custom properties like Type on the active configuration.
4. Run the macro to apply the template: <NMB>-PRT-<$PRP:Type>-<_ConfName_>.
5. Counter increments each run; edit NMB_FORMAT for different padding.