CAD Forum

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

Code: Select all

swPackAndGo.IncludeDrawings = True