Renaming File Names in PackAndGo Automatically

okan.karaca · Unread post by **okan.karaca** » Thu Feb 02, 2023 4:33 am

Hello, I'm new to VBA. I found this code where automatically rename the files but somehow i coulndt manage to run it. Could you please help me to solve this issue?

Here is the code,

Code: Select all


Sub main()

SavingPath = InputBox("Where do you want to pack and go? Enter the path here:")

Dim FileSystemObject As Object
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")

If Not FileSystemObject.FolderExists(SavingPath) Then

    MsgBox ("Folder does not exist!")
End If

Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swModelDocExt = swModel.Extension
Dim PackAndGoObj As PackAndGo
Set PackAndGoObj = swModelDocExt.GetPackAndGo

Dim VDocs
Dim result As Boolean
PackAndGoObj.FlattenToSingleFolder = True
PackAndGoObj.IncludeToolboxComponents = True
PackAndGoObj.IncludeDrawings = True
result = PackAndGoObj.GetDocumentNames(VDocs)

'Presetting the Counters
Dim Partcounter As Long: Partcounter = 1
Dim AssebmlyCounter As Long: AssebmlyCounter = 1
Dim DrawingCounter As Long: DrawingCounter = 1

For i = 0 To UBound(VDocks)

If Split(VDocks(i), ".")(1) = "sldprt" Then

'Replace the 21116- with your own prefix
VDocs(i) = "21116-" & Partcounter & ".sldprt"
Partcounter = Partcounter + 1

ElseIf Split(VDocs(i), ".")(1) = "sldasm" Then
VDocs(i) = "21116A-" & AssemblyCounter & ".sldasm"
AssemblyCounter = AssemblyCounter + 1

ElseIf Split(VDocks(i), ".")(1) = "slddrw" Then
VDocs(i) = "21116D-" & DrawingCounter & ".slddrw"
DrawingCounter = DrawingCounter + 1

End If

Next i

result = PackAndGo.SetSaveToName(True, SavingPath)
result = PackAndGo.SetDocumentSaveToNames(VDocks)

Dim vResult

vResult = swModelDocExt.SavePackAndGo(PackAndGoObj)

MsgBox "All Packed - Going Where"

End Sub