Problème boucle VBA MAcro

Out of category
1

Bonjour,

J'ai créé une macro me permettant de copier un assemblage existant dans un dossier spécifique, d'ouvrir la copie et de remplacer un assemblage à l'intérieur. Le tout à partir d'une liste excel.

La première boucle fonctionne correctement, mais à la deuxième, l'assemblage copié ne s'ouvre pas et fait planter mon solidworks.

Après la ligne:

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

 

Auriez vous une idée du problème?

Merci à vous.

Le code avec les chemins masqués:

' ******************************************************************************
' 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

Salut,
Essai d'instancier ton objet Part de cette façon :

Dim part As SldWorks.ModelDoc2

 

Ensuite vérifie en faisant un "pas à pas" que ta variable NewNameA est correcte. Elle doit contenir le chemin complet et pas seulement le nom du fichier.
Ensuite que le fichier existe. Tu devrais d'ailleurs gérer cette erreur dans ton code.

Bonne journée.

3

Merci @remrem

Du coup j'ai remplacé 'part' par 'swModel' en l'instanciant et ça fonctionne.

Super ;)

4

Comme je te le proposait, tu peux vérifier l'existence des fichiers en utilisant cette fonction :

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

 

1 « J'aime »