Macro to collect all reference documents of assembly into a folder
This VBA macro allows to collect all output files such as DXF, DWG, PDF etc. from all referenced parts and sub-assembly documents on all levels and copy to a specified folder.
Referenced parts and sub-assemblies can be located in any directory. It is not required those to be in the same folder or drive of a main assembly.
For example the main assembly TopAssm1.sldasm is saved in C:\Assms folder and it refers 2 part files located in D:\Parts\A\Part1.sldprt and D:\Parts\B\Part2.sldprt. DXF and PDF files were created for Part1 and Part2 and saved in the same folder, i.e. D:\Parts\A\Part1.dxf, D:\Parts\A\Part1.pdf, D:\Parts\B\Part2.dxf, D:\Parts\B\Part2.pdf. As the result of running this macro all those 4 files will be copied to the specified output folder.
- Reference documents must have the same name as the file they derived from, i.e. Part1.pdf is derived from Part1.sldprt
- Reference documents of the main assembly will also be included
- Macro will open the folder browse dialog to select the output folder
- All file paths which are copied are output to the Immediate window of VBA editor
- Suppressed components will not be included into the collection
- Assembly opened in Large Design Review mode is not supported
Macro can be configured by changing the constants at the beginning of the macro
Const SEARCH_SUB_FOLDERS As Boolean = False Const EXTENSIONS As String = "dxf,pdf" Const ALLOW_OVERWRITE As Boolean = False
SEARCH_SUB_FOLDERS indicates if macro should recursively search referenced documents. If this option is set to False only files next to the source files will be collected (e.g. Part1.dxf must be in the same folder as Part1.sldprt). In some cases output files can be placed into sub-folders (e.g. DXFs\Part1.dxf of Part1.sldprt) to collect such files set the SEARCH_SUB_FOLDERS to True. Note, if any child folder contains another file with the same name it will also be collected (e.g. A\B\C\Part1.pdf).
EXTENSIONS is a comma-separated list of file extension to collect.
ALLOW_OVERWRITE option indicates if the files in the destination directory need to be overwritten if exist. It is recommended to set this option to False and manually clean the target directory. This would reduce the risk of overwriting the files and catching the potential errors.
Const SEARCH_SUB_FOLDERS As Boolean = False Const EXTENSIONS As String = "dxf,pdf" Const ALLOW_OVERWRITE As Boolean = False Dim swApp As SldWorks.SldWorks Sub main() Set swApp = Application.SldWorks try_: On Error GoTo catch_ Dim swAssy As SldWorks.AssemblyDoc Set swAssy = swApp.ActiveDoc If False <> swAssy.IsOpenedViewOnly() Then Err.Raise vbError, "", "Assembly opened in Large Design Review mode is not supported" End If Dim exts As Variant exts = Split(EXTENSIONS, ",") Dim i As Integer For i = 0 To UBound(exts) exts(i) = Trim(CStr(exts(i))) Next Dim destDir As String destDir = BrowseForFolder("Select folder to copy documents to") If destDir = "" Then Exit Sub End If Dim vRefDocs As Variant vRefDocs = CollectRefDocuments(swAssy, exts, SEARCH_SUB_FOLDERS) If Not IsEmpty(vRefDocs) Then CopyRefDocs vRefDocs, destDir Else Err.Raise vbError, "", "There are no referenced documents" End If GoTo finally_ catch_: swApp.SendMsgToUser2 Err.Description, swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk finally_: End Sub Sub CopyRefDocs(refDocs As Variant, destFolder As String) Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim i As Integer If Right(destFolder, 1) <> "\" Then destFolder = destFolder & "\" End If For i = 0 To UBound(refDocs) Dim srcFilePath As String srcFilePath = CStr(refDocs(i)) Debug.Print "Copying " & srcFilePath & " to " & destFolder fso.CopyFile srcFilePath, destFolder, ALLOW_OVERWRITE Next End Sub Function CollectRefDocuments(assy As SldWorks.AssemblyDoc, exts As Variant, includeSubFolder As Boolean) As Variant Dim isInit As Boolean isInit = False Dim vComps As Variant vComps = assy.GetComponents(False) Dim refDocsPath() As String Dim i As Integer For i = -1 To UBound(vComps) Dim swComp As SldWorks.Component2 If i = -1 Then Set swComp = assy.ConfigurationManager.ActiveConfiguration.GetRootComponent() Else Set swComp = vComps(i) End If If False = swComp.IsSuppressed() Then Dim path As String path = swComp.GetPathName() Dim dir As String dir = Left(path, InStrRev(path, "\")) Dim vRefFiles As Variant vRefFiles = GetFiles(dir, includeSubFolder, exts) Dim j As Integer Dim srcFileName As String srcFileName = GetFileNameWithoutExtension(path) For j = 0 To UBound(vRefFiles) Dim refFilePath As String refFilePath = CStr(vRefFiles(j)) Dim refFileName As String refFileName = GetFileNameWithoutExtension(refFilePath) If LCase(srcFileName) = LCase(refFileName) Then Dim add As Boolean add = False If Not isInit Then isInit = True ReDim refDocsPath(0) add = True Else If Not Contains(refDocsPath, refFilePath) Then ReDim Preserve refDocsPath(UBound(refDocsPath) + 1) add = True End If End If If add Then refDocsPath(UBound(refDocsPath)) = refFilePath End If End If Next End If Next If isInit Then CollectRefDocuments = refDocsPath Else CollectRefDocuments = Empty End If End Function Function GetFileNameWithoutExtension(filePath As String) As String GetFileNameWithoutExtension = Mid(filePath, InStrRev(filePath, "\") + 1, InStrRev(filePath, ".") - InStrRev(filePath, "\") - 1) End Function Function GetFiles(path As String, includeSubFolders As Boolean, exts As Variant) As Variant Dim paths() As String Dim isInit As Boolean isInit = False Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim folder As Object Set folder = fso.GetFolder(path) CollectFilesFromFolder folder, includeSubFolders, exts, paths, isInit If isInit Then GetFiles = paths Else GetFiles = Empty End If End Function Sub CollectFilesFromFolder(folder As Object, includeSubFolders As Boolean, exts As Variant, ByRef paths() As String, ByRef isInit As Boolean) For Each file In folder.files Dim fileExt As String fileExt = Right(file.path, Len(file.path) - InStrRev(file.path, ".")) If Contains(exts, fileExt) Then If Not isInit Then ReDim paths(0) isInit = True Else ReDim Preserve paths(UBound(paths) + 1) End If paths(UBound(paths)) = file.path End If Next If includeSubFolders Then Dim subFolder As Object For Each subFolder In folder.SubFolders CollectFilesFromFolder subFolder, includeSubFolders, exts, paths, isInit Next End If End Sub Function BrowseForFolder(Optional title As String = "Select Folder") As String Dim shellApp As Object Set shellApp = CreateObject("Shell.Application") Dim folder As Object Set folder = shellApp.BrowseForFolder(0, title, 0) If Not folder Is Nothing Then BrowseForFolder = folder.Self.path End If End Function Function Contains(arr As Variant, item As String) As Boolean Dim i As Integer For i = 0 To UBound(arr) If LCase(arr(i)) = LCase(item) Then Contains = True Exit Function End If Next Contains = False End Function