'Saves each configuration of a SolidWorks Part file to a separate file with
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim ModelDoc As SldWorks.ModelDoc2
Dim ModelDocCopy As SldWorks.ModelDoc2
Dim strNewFileName As String
Dim ConfigNames As Variant
Dim strActiveConfig As String
Dim nCount As Long
Dim nCountCopy As Long
Dim RetVal As Long
Sub Main()
Set swApp = Application.SldWorks
Set ModelDoc = swApp.ActiveDoc
If Not ModelDoc Is Nothing Then
If ModelDoc.GetType = 3 Then 'document is a drawing, exit sub
MsgBox "Active document is not a SolidWorks part or assembly!", vbInformation
Exit Sub
End If
If ModelDoc.GetPathName = "" Then 'model not saved
MsgBox "Please save the model!", vbInformation
Exit Sub
End If
'Get all the configurations names into an array
ConfigNames = ModelDoc.GetConfigurationNames
'Get the active configuration so we can switch back to it when finished
strActiveConfig = ModelDoc.GetActiveConfiguration.Name
For nCount = 0 To UBound(ConfigNames)
'Activate the configuration
ModelDoc.ShowConfiguration2 ConfigNames(nCount)
'Create a filename for the Save as copy
strNewFileName = CreateNewFileName(ModelDoc.GetPathName, ConfigNames(nCount))
'Debug.Print strNewFileName
'Save a copy of the file
RetVal = ModelDoc.SaveAsSilent(strNewFileName, True)
'Open the new file with the Correct Configuration
Set ModelDocCopy = swApp.OpenModelConfiguration(strNewFileName, ConfigNames(nCount))
For nCountCopy = 0 To UBound(ConfigNames)
If ConfigNames(nCountCopy) <> ConfigNames(nCount) Then
'Delete each configuration except the one that is the active one
ModelDocCopy.DeleteConfiguration2 (ConfigNames(nCountCopy))
End If
Next
'Save and close the modelcopy
ModelDocCopy.SaveSilent
swApp.CloseDoc ModelDocCopy.GetPathName
Set ModelDocCopy = Nothing
Next
'Show the configuration that was active when we before we started
ModelDoc.ShowConfiguration2 strActiveConfig
MsgBox "Finished!", vbInformation
End If
Set ModelDoc = Nothing
Set ModelDocCopy = Nothing
Set swApp = Nothing
End Sub
Function CreateNewFileName(strFileName As String, ByVal strCfgName As String) As String
Dim objFS As Scripting.FileSystemObject
Dim strBaseName As String
Dim strExt As String
Dim strPath As String
Dim strNewFileName
Set objFS = CreateObject("Scripting.FileSystemObject")
strBaseName = objFS.GetBaseName(strFileName)
strExt = objFS.GetExtensionName(strFileName)
strPath = objFS.GetParentFolderName(strFileName)
'Add the config name to the base name
strBaseName = strBaseName & " (" & strCfgName & ")"
'add the extension
strNewFileName = strBaseName & "." & strExt
'Clean the filename to remove any invalid chars
strNewFileName = CleanFileName(strNewFileName)
'Build the full path
strNewFileName = objFS.BuildPath(strPath, strNewFileName)
'Return the new filename including the full path
CreateNewFileName = strNewFileName
Set objFS = Nothing
End Function
Function CleanFileName(ByVal strFileName As String) As String
Dim InvalidChars As Variant
Dim x As Integer
'Create array of invalid filename chars
InvalidChars = Array("/", "\", "*", "?", "''", "<", ">", "|")
'Loop through the array and replace each instance of the invalid chars of the string
For x = 0 To UBound(InvalidChars)
strFileName = Replace(strFileName, InvalidChars(x), Space(1), , , vbTextCompare)
Next
'Return the filename cleaned and trimmed
CleanFileName = Trim(strFileName)
End Function
![[cheers]](/data/assets/smilies/cheers.gif "[cheers] [cheers]")
