For the macro to work, it is necessary: a saved non-empty assembly must be opened. You must have Excel installed.
In the Microsoft Visual Basic editor, in the Tools - References menu, check the box: Microsoft Excel XX.0 Object Library
It is worth paying attention: if the element occurs several times in the project, then the value of the "envelope" will be set to the last found element.
Full VB cod here:
Code: Select all
Public FILES_DIC 'Dictionary with information about copied files.
Public UP_ASM_KEY As String 'Topmost assembly with file extension
Public IsSave_Convert_Files As Boolean 'Logic for deciding whether to copy envelopes to an archive.
Dim swApp As SldWorks.SldWorks
Sub main()
IsSave_Convert_Files = False 'don't save envelopes by default, final choice later
Set swApp = Application.SldWorks
Dim swModel As SldWorks.ModelDoc2
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
MsgBox "Open Assembly" 'Check for nothing open
End If
If swModel.GetType() = swDocumentTypes_e.swDocASSEMBLY Then 'If assembly is open
If swApp.ActiveDoc.GetPathName = "" Then 'Assembly not saved
MsgBox "Assembly must be saved", vbOKOnly 'chao come back as soon as you save the assembly.
End
End If
Dim swAssy As SldWorks.AssemblyDoc
Set swAssy = swModel 'find out that the open model is a saved assembly, redefine it so as not to get confused.
swAssy.ResolveAllLightWeightComponents True 'Solve all reduced components
Dim vComps As Variant
vComps = swAssy.GetComponents(False) ''Find all the elements in the assembly. FALSE - means that in all subassemblies at all levels.
If UBound(vComps) < 1 Then
MsgBox "Assembly is empty, the macro will be Stopped!" 'Assembly was empty - enough of these jokes, chao
End
End If
' Declare Excel to read files from their folders. I prefer to use Excel.
' But this will require you to connect the Excel library to the project.
' how to do it?
' In the VisualBasic macro editor in SolidWorks.
' Open the menu: Tools - References - find and check the box for Microsoft Excel XX.0 Object Library.
' If you don't have Excel, take the trouble to rewrite the macro using bare VisualBasic functions only
' But without Excel, it will not be possible to display the list of files included in the assembly in an Excel spreadsheet for visual control.
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Set xlApp = CreateObject("Excel.Application") 'Excel background launch
Set xlWB = Workbooks.Add 'We add one empty book, otherwise it may not work out all the functions.
With xlWB
.Title = "All_Components of " & FileNameWithExtension(swApp.ActiveDoc.GetPathName)
.Subject = "Save_Project"
'.SaveAs FileName:=GetFileNameWithoutExtension(swApp.ActiveDoc.GetPathName) & ".xls"
.Worksheets(1).Activate
End With
xlApp.Visible = False 'Excel don't show up
xlApp.DisplayAlerts = False 'I don't want to see your Excel errors
Dim Resalt As String 'Path to the selected folder where the project will be saved
Dim BrowseResalt As String 'Path to the selected folder where the project will be saved with the string
'Open the dialog box for selecting the folder where the project will be saved
With xlApp.FileDialog(4) '(msoFileDialogFolderPicker)
.InitialFileName = Left(swApp.ActiveDoc.GetPathName, InStrRev(swApp.ActiveDoc.GetPathName, "\")) 'We start with the folder itself with the Loaded assembly in the SW
.Title = "Select folder ==DESTINATION== where the project will be copied"
.Show
On Error Resume Next
Err.Clear
Resalt = .SelectedItems(1)
If Err.Number <> 0 Then
BrowseResalt = ""
End If
End With
BrowseResalt = CStr(Resalt) 'the path to the folder is stored here "E:\_PROGECT\GOR\_DB_2022\44M"
'check if the folder is selected, if yes, then go to it, if not, then take it from the original and add a subfolder: _DUMP_PROJECT(n)
If BrowseResalt = "" Then 'folder not selected
Result = MsgBox("Path not selected. Save to _DUMP_PROJECT(n) folder in assembly folder?", vbOKCancel, "Information")
If Result = vbCancel Then
End 'Refusal - exit the macro. Chao
Else
' Since the macro can repeatedly save the project to the source folder of the assembly,
' we check whether folders with archives exist, find the last index and create the next one.
n = 1
Do While FolderExists(Left(swApp.ActiveDoc.GetPathName, InStrRev(swApp.ActiveDoc.GetPathName, "\")) & "_DUMP_PROJECT" & n & "\")
n = n + 1
Loop
BrowseResalt = Left(swApp.ActiveDoc.GetPathName, InStrRev(swApp.ActiveDoc.GetPathName, "\")) & "_DUMP_PROJECT" & n & "\"
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CreateFolder BrowseResalt ' The new project folder is saved by default.
End If
Else
BrowseResalt = BrowseResalt & "\" 'Correction of the folder path so as not to be distracted in the future.
End If
Set FILES_DIC = CreateObject("Scripting.Dictionary")
UP_ASM_KEY = FileNameWithExtension(swApp.ActiveDoc.GetPathName) 'Topmost assembly name with file extension
AddCompToDic swApp.ActiveDoc, False, False 'We add the top assembly first to the dictionary, and it is not Virtual, and it is not an Envelope.
' We drive all included in the Dictionary.
Dim i As Integer
For i = 0 To UBound(vComps)
Dim swComp As SldWorks.Component2
Set swComp = vComps(i)
AddCompToDic swComp.GetModelDoc2(), swComp.IsVirtual, swComp.IsEnvelope
Next
Result = MsgBox("If there are ENVELOPES among the components, save them?", vbYesNo, "Information")
If Result = vbYes Then IsSave_Convert_Files = True 'The final value of the logic on envelopes.
SeeComponent xlWB 'In any case, we create an excel spreadsheet with a list of all the components.
'And now we ask: the user wants to look at it. So the table exists in the background.
Result = MsgBox("Display project table in Excel file?", vbOKCancel, "Information")
If Result = vbCancel Then 'No - ansver
'clean up excel from memory
xlWB.Close
Set xlWB = Nothing
xlApp.Quit
Set xlApp = Nothing
Else
xlApp.Visible = True 'Show Excel spreadsheet
End If
Result = MsgBox("Copy project to folder?:" & Chr(10) & BrowseResalt, vbYesNo, "Information")
If Result = vbNo Then
End 'We do not copy anything, perhaps we saw an error in the Excel spreadsheet and want to copy it.
'The macro is stop, the Excel spreadsheet will remain hanging in RAM.
Else
CopyAllComponentToOneDir (BrowseResalt) 'The entire project is copied. To the specified folder
End If
Shell "explorer " & BrowseResalt, vbNormalFocus 'Open the folder in the Operating System with the newly copied project for viewing.
Else ' If something else (not assembly) is open
MsgBox "Only assembly documents are supported", vbOKOnly 'Error message and chao
End If
End Sub
' The function adds a component to the Dictionary.
Public Function AddCompToDic(ComponentToCopy As SldWorks.ModelDoc2, VIRTUALis As Boolean, CONVERTis As Boolean)
'The dictionary has the following structure.
'Key - File name with extension.
'The value is a one-dimensional array with 4 elements:
'0. Path where the copied file is located (String)
'1. Is it virtual (True/False)
'2. End-to-end number of mentions in the project (Integer)
'3. Is it an envelope (True/False)
Dim KEY_File_Name As String 'Key - File name with extension.
Dim WAY_COPY_FROM_FULL As String 'Path full where the copied file is located
Dim ArrPar As Variant 'Array for Dictionary value
ReDim ArrPar(0 To 3) As Variant 'Array: Path, Virtual, Count, Envelope
WAY_COPY_FROM_FULL = ComponentToCopy.GetPathName
KEY_File_Name = FileNameWithExtension(WAY_COPY_FROM_FULL)
If WAY_COPY_FROM_FULL <> "" And KEY_File_Name <> "" Then
If FILES_DIC.Exists(KEY_File_Name) Then 'Item repeats add quantity
ArrPar(0) = FILES_DIC(KEY_File_Name)(0) 'Path
ArrPar(1) = CBool(FILES_DIC(KEY_File_Name)(1)) 'Virtual
ArrPar(2) = CInt(FILES_DIC(KEY_File_Name)(2)) + 1 'Count
ArrPar(3) = CBool(FILES_DIC(KEY_File_Name)(3)) 'Envelope
FILES_DIC.Remove (KEY_File_Name) 'remove an element from the dictionary to then add it with the updated count.
Else 'Adding a new element
ArrPar(0) = WAY_COPY_FROM_FULL
ArrPar(1) = VIRTUALis
ArrPar(2) = 1
ArrPar(3) = CONVERTis
End If
'It is worth paying attention:
'if the element occurs several times in the project,
'then the value of the "envelope" will be set to the last found element.
FILES_DIC.Add KEY_File_Name, ArrPar 'Adding an element.
End If
End Function
' The function generates an excel table with a list of all components based on the Dictionary with components.
Public Function SeeComponent(seelWB As Excel.Workbook)
With seelWB.Sheets(1) 'Assign column names.
.Cells(1, 1) = "TYPE"
.Cells(1, 2) = "Name"
.Cells(1, 3) = "State"
.Cells(1, 4) = "Quantity"
.Cells(1, 5) = "Path"
Dim ArrKeys As Variant
ArrKeys = FILES_DIC.Keys
For i = LBound(ArrKeys) To UBound(ArrKeys)
Dim CompType As String 'Check for assembly part
If InStr(1, CStr(ArrKeys(i)), ".SLDPRT") > 0 Or InStr(1, CStr(ArrKeys(i)), ".sldprt") > 0 Then
CompType = "PRT"
ElseIf InStr(1, CStr(ArrKeys(i)), ".SLDASM") > 0 Or InStr(1, CStr(ArrKeys(i)), ".sldasm") > 0 Then
CompType = "ASM"
Range(Cells(2 + i, 1), Cells(2 + i, 5)).Font.Color = vbBlue 'We paint all the assemblies blue
If i = 0 Then Range(Cells(2 + i, 1), Cells(2 + i, 5)).Font.Bold = True 'We make the top assembly bold
End If
Dim waycomp As String
waycomp = GetFileDir(FILES_DIC.Item(ArrKeys(i))(0))
Dim isVirt As String
isVirt = ""
If CBool(FILES_DIC.Item(ArrKeys(i))(1)) = True Then
isVirt = "Virtual"
Range(Cells(2 + i, 1), Cells(2 + i, 5)).Font.Color = RGB(178, 178, 178) 'grey text - virtual
waycomp = ""
End If
Dim isConv As String
isConv = ""
If CBool(FILES_DIC.Item(ArrKeys(i))(3)) = True Then
isConv = "Envelope"
Range(Cells(2 + i, 1), Cells(2 + i, 5)).Interior.Color = RGB(255, 204, 255) 'pink background envelope
If Not IsSave_Convert_Files Then waycomp = ""
End If
'combinations of envelopes and simultaneously virtual
Dim Sostojae As String
If isVirt <> "" Then
If isConv <> "" Then
Sostojanie = isVirt & "\" & isConv
Else
Sostojanie = isVirt
End If
Else
If isConv <> "" Then
Sostojanie = isConv
Else
Sostojanie = ""
End If
End If
.Cells(2 + i, 1) = CompType '"Part/assembly"
.Cells(2 + i, 2) = ArrKeys(i) '"Name"
.Cells(2 + i, 3) = Sostojanie '"Virtual"
.Cells(2 + i, 4) = FILES_DIC.Item(ArrKeys(i))(2) '"Quantity"
.Cells(2 + i, 5) = waycomp '"Path"
Next i
.Columns("A:E").AutoFit
.Columns("D").HorizontalAlignment = xlCenter
End With
End Function
' The function copies all elements of the Dictionary to one folder
Public Function CopyAllComponentToOneDir(TargetWay As String)
Dim ErrorCopyFiles As String
ErrorCopyFiles = ""
Dim ArrKeys As Variant
ArrKeys = FILES_DIC.Keys 'Extract all dictionary keys (file names with extension) into an array.
For i = LBound(ArrKeys) To UBound(ArrKeys)
Dim WAY_COPY_FROM_FULL As String
WAY_COPY_FROM_FULL = FILES_DIC.Item(ArrKeys(i))(0) 'We find the path to the file by the file name in the dictionary.
Dim WAY_COPY_TO_FULL As String
Dim NAME_COPYfile_withExt As String
NAME_COPYfile_withExt = CStr(ArrKeys(i))
WAY_COPY_TO_FULL = TargetWay & NAME_COPYfile_withExt 'Glue the full path of the copy destination with the file name with the extension
If WAY_COPY_FROM_FULL <> "" And NAME_COPYfile_withExt <> "" And WAY_COPY_TO_FULL <> "" And TargetWay <> "" Then 'Check that there are no empty paths and names
If Not CBool(FILES_DIC.Item(ArrKeys(i))(1)) Then 'NOT VIRTUAL
If CBool(FILES_DIC.Item(ArrKeys(i))(3)) And IsSave_Convert_Files Or Not CBool(FILES_DIC.Item(ArrKeys(i))(3)) Then 'If (Envelope and CanEnvelopes) or (Not Envelope)
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
If Not fs.FileExists(WAY_COPY_TO_FULL) Then 'We check that the copied file really exists in the system, this is the last time.
fs.copyfile WAY_COPY_FROM_FULL, WAY_COPY_TO_FULL 'COPYING
End If
End If
End If
Else
ErrorCopyFiles = ErrorCopyFiles & CStr(ArrKeys(i)) & Chr(10) 'We fill the string variable with copy errors, if any.
End If
Next i
'If, after all the copying, the string variable with copy errors is not empty, we display a message that the copy failed.
If ErrorCopyFiles <> "" Then MsgBox "Failed to copy the following files:" & Chr(10) & ErrorCopyFiles
End Function
'Helper functions here
'File name with extension
Public Function FileNameWithExtension(path As String) As String
On Error GoTo er1l
FileNameWithExtension = Mid(path, InStrRev(path, "\") + 1, Len(path))
Exit Function
er1l: FileNameWithExtension = ""
End Function
'File name without extension: "E:\_SWsys\macro\SW_PROP_MAINv01.swp" -> "SW_PROP_MAINv01"
Public Function GetFileNameWithoutExtension(ByVal path As String) As String
On Error GoTo er1
GetFileNameWithoutExtension = Mid(path, InStrRev(path, "\") + 1, InStrRev(path, ".") - InStrRev(path, "\") - 1)
Exit Function
er1: GetFileNameWithoutExtension = ""
End Function
'Folder name "E:\_SWsys\macro\SW_PROP_MAINv01.swp" -> "E:\_SWsys\macro\"
Public Function GetFileDir(ByVal path As String) As String
On Error GoTo er1
GetFileDir = Mid(path, 1, InStrRev(path, "\"))
Exit Function
er1: GetFileDir = ""
End Function
'Check if file exists or not
Public Function FileExists(filePath As String) As Boolean
FileExists = Dir(filePath) <> ""
End Function
'Check whether the folder exists or not
Function FolderExists(ByRef path As String) As Boolean
On Error Resume Next
FolderExists = GetAttr(path)
End Function
