MAcro VBA loop problem

Out of category
1

Hello

I created a macro that allows me to copy an existing assembly to a specific folder, open the copy, and replace an assembly inside it. All from an excel list.

The first loop works fine, but on the second loop, the copied assembly doesn't open and crashes my solidworks.

After the line:

 'ouverture de la copie
Set Part = swApp.OpenDoc6(NewNameA, 2, 0, "", longstatus, longwarnings)

 

Do you have any idea of the problem?

Thank you.

The code with hidden paths:

' ******************************************************************************
' swx21552\Macro1.swb - macro recorded on 03/15/21
' ******************************************************************************
Dim swApp As Object

Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim retVal As Long
'Dim DernLigne As Long


Dim AssRemp As String
Dim AssRempSE As String
Dim ChemRemp As String
Dim NomRempComp As String
Dim fileNameA As String
Dim NewNameA As String

Dim i As Long
Dim DernLigneP As Long

Dim xlApp As Excel.Application
Dim wbk As Excel.Workbook
Dim Sht As Excel.Worksheet



Sub main()

Set swApp = Application.SldWorks
Set xlApp = New Excel.Application


With xlApp
    .Visible = False
    
    DoEvents

'Fige l'écran
xlApp.ScreenUpdating = False

'Ouvre le fichier excel
Workbooks.Open fileName:="XXX.xlsm"

Set wbk = ActiveWorkbook
Set Sht = wbk.ActiveSheet

'Compte le nombre de lignes du classeur Excel
DernLigneP = Sht.Range("C" & Rows.Count).End(xlUp).Row

'Définition de l'assemblage à copier
fileNameA = "XXX.SLDASM"


'Début de la boucle
For i = 1 To DernLigneP Step 1
    DoEvents
    
    'Définition du sous-assemblage de remplacement
    ChemRemp = Sht.Cells(i, 3).Value    'Excel - lecture chemin
    AssRemp = Sht.Cells(i, 1).Value     'Excel - lecture nom assemblage
        
    'Chemin + nom du sous-assemblage
    NomRempComp = ChemRemp & "\" & AssRemp
    
    'Récupération du nom du sous-assemblage sans extension
    If InStr(AssRemp, ".") > 0 Then
        AssRempSE = Left(AssRemp, InStr(AssRemp, ".") - 1)
    Else: AssRempSE = AssRemp
    End If
        
    'Définition du nouveau nom de l'assemblage copié
    NewNameA = "XXX" & AssRempSE & " BIM " & ".SLDASM"
    
    'Copie de l'assemblage et renommage
    retVal = swApp.CopyDocument(fileNameA, NewNameA, "", "", swMoveCopyOptionsOverwriteExistingDocs)
    
    'Appel de la procédure de remplacement du sous-assemblage
    Call remplacement
    
Next i

End With
xlApp.Quit

End Sub

Sub remplacement()

 'ouverture de la copie
Set Part = swApp.OpenDoc6(NewNameA, 2, 0, "", longstatus, longwarnings)
    
    DoEvents
    
    Set Part = swApp.ActiveDoc
    Part.ClearSelection2 True
    
    'Selection du sous-assemblage à remplacer
    boolstatus = Part.Extension.SelectByID2("XXX@" & AssRempSE & " BIM ", "COMPONENT", 0, 0, 0, False, 0, Nothing, 0)
    
    'Remplacement
    boolstatus = Part.ReplaceComponents2(NomRempComp, "Avant", False, 0, True)
    boolstatus = Part.EditRebuild3()
    
    'Sauvegarde
    longstatus = Part.Save
    
    'Msg sauvegarde assemblage ok
    Debug.Print (AssRempSE & " BIM " & ".SLDASM sauvegardé.")
    
    ' Save As IFC
    'longstatus = Part.SaveAs3("XXX" & AssRempSE & " BIM " & ".IFC", 0, 0)
    'Debug.Print (AssRempSE & " BIM " & ".IFC sauvegardé.")

    
    'Fermeture du fichier
    'swApp.CloseDoc Part
    swApp.CloseDoc NewNameA
    
 
    'If MsgBox("Assemblage suivant?", vbOKCancel) = vbCancel Then Exit Sub
    
End Sub

 

2

Hello
Try instantiating your object Start this way:

Dim part As SldWorks.ModelDoc2

 

Then check by doing a "step by step" that your NewNameA variable is correct. It should contain the full path and not just the file name.
Then that the file exists. You should also handle this error in your code.

Have a nice day.

3

Thank you @remrem

So I replaced 'part' with 'swModel' by instantiating it and it works.

Great ;)

4

As I suggested, you can check the existence of the files using this function:

Function IsFileExist(FullName As String) As Boolean
 IsFileExist = Dir(FullName) <> ""
End Function

 

1 Like