VBA SOLIDWORKS Pack and Go rename doesn't work if there's a design table linked to the part file (Controlling from Excel)

Viewed 480

I have a code that takes a specific part and is supposed to "Pack and Go" to another specific location while renaming these new created files, however if I have a design table linked to the part I am trying to "Pack and Go" the renaming of files doesn't happen. What could be the cause of this problem?

The code:

Option Explicit

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swPackAndGo As SldWorks.PackAndGo
Dim OpenFilePath As String
Dim OpenFileName As String
Dim SavePath As String
Dim SaveName As String
Dim myFileName As String
Dim myExtension As String
Dim pgFileNames As Variant
Dim pgFileStatus As Variant
Dim status As Boolean
Dim statuses As Variant
Dim i As Long
Dim partDocExt As SldWorks.ModelDocExtension

Sub PackAndGo()

Call Calculate_TFVPM_FormatSketchFileName

OpenFilePath = "G:\Format Sketch\FormatSketch.SLDPRT"
SavePath = "G:\Format Sketch\Temp\"
SaveName = NewSaveName

On Error Resume Next
Set swApp = GetObject(, "SldWorks.Application")
Set swModel = swApp.OpenDoc(OpenFilePath, swDocPART)

'Set swModel = swApp.ActiveDoc
OpenFilePath = swModel.GetPathName
OpenFileName = Mid(OpenFilePath, InStrRev(OpenFilePath, "\") + 1, InStrRev(OpenFilePath, ".") - InStrRev(OpenFilePath, "\") - 1)

Set swModelDocExt = swModel.Extension

'Get Pack and Go object
Set swPackAndGo = swModelDocExt.GetPackAndGo

'Include any drawings
swPackAndGo.IncludeDrawings = True

'Set folder where to save the files
status = swPackAndGo.SetSaveToName(True, SavePath)

'Get files path
status = swPackAndGo.GetDocumentSaveToNames(pgFileNames, pgFileStatus)
For i = 0 To UBound(pgFileNames)
    myFileName = Mid(pgFileNames(i), InStrRev(pgFileNames(i), "\") + 1, InStrRev(pgFileNames(i), ".") - InStrRev(pgFileNames(i), "\") - 1)
    myExtension = Right(pgFileNames(i), Len(pgFileNames(i)) - InStrRev(pgFileNames(i), ".") + 1)

    'Replace name
    If LCase(myFileName) = LCase(OpenFileName) Then
        pgFileNames(i) = SavePath & SaveName & myExtension
    End If
Next

'Set files path
status = swPackAndGo.SetDocumentSaveToNames(pgFileNames)

'Flatten the Pack and Go folder structure; save all files to the root directory
swPackAndGo.FlattenToSingleFolder = True

'Pack and Go
statuses = swModelDocExt.SavePackAndGo(swPackAndGo)
        
'Close initial template
swApp.CloseDoc (swModel.GetPathName)
        
End Sub
1 Answers

This should work for a given part with a design table

Option Explicit
Sub PackAndGo()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swPackAndGo As SldWorks.PackAndGo
Dim OpenFilePath As String
Dim OpenFileName As String
Dim SavePath As String
Dim SaveName As String
Dim myFileName As String
Dim myExtension As String
Dim pgFileNames As Variant
Dim pgFileStatus As Variant
Dim status As Boolean
Dim statuses As Variant
Dim i As Long

Call Calculate_TFVPM_FormatSketchFileName

OpenFilePath = "G:\Format Sketch\FormatSketch.SLDPRT"
SavePath = "G:\Format Sketch\Temp\"
SaveName = NewSaveName

Set swApp = Application.SldWorks
Set swModel = swApp.OpenDoc(openFile, swDocPART)
'Set swModel = swApp.ActiveDoc
OpenFilePath = swModel.GetPathName
OpenFileName = Mid(OpenFilePath, InStrRev(OpenFilePath, "\") + 1, InStrRev(OpenFilePath, ".") - InStrRev(OpenFilePath, "\") - 1)

Set swModelDocExt = swModel.Extension

'Get Pack and Go object
Set swPackAndGo = swModelDocExt.GetPackAndGo

'Include any drawings
swPackAndGo.IncludeDrawings = True

'Set folder where to save the files
status = swPackAndGo.SetSaveToName(True, SavePath)

'get Paths
status = swPackAndGo.GetDocumentSaveToNames(pgFileNames, pgFileStatus)

'Flatten the Pack and Go folder structure; save all files to the root directory
swPackAndGo.FlattenToSingleFolder = True

'Pack and Go
statuses = swModelDocExt.SavePackAndGo(swPackAndGo)

'Rename file
For i = 0 To UBound(pgFileNames)
    myFileName = Mid(pgFileNames(i), InStrRev(pgFileNames(i), "\") + 1, InStrRev(pgFileNames(i), ".") - InStrRev(pgFileNames(i), "\") - 1)
    myExtension = Right(pgFileNames(i), Len(pgFileNames(i)) - InStrRev(pgFileNames(i), ".") + 1)

    If LCase(myFileName) = LCase(OpenFileName) Then
        Name pgFileNames(i) As SavePath & SaveName & myExtension
    End If
Next
End Sub
Related