Problem mit der MAcro VBA-Schleife

Out of category
1

Hallo

Ich habe ein Makro erstellt, mit dem ich eine vorhandene Assembly in einen bestimmten Ordner kopieren, die Kopie öffnen und eine darin enthaltene Assembly ersetzen kann. Alles aus einer Excel-Liste.

Die erste Schleife funktioniert gut, aber in der zweiten Schleife wird die kopierte Baugruppe nicht geöffnet und stürzt mein SolidWorks ab.

Nach der Zeile:

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

 

Haben Sie eine Vorstellung von dem Problem?

Vielen Dank.

Der Code mit versteckten Pfaden:

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

Hallo
Versuchen Sie, Ihr Objekt zu instanziieren Starten Sie folgendermaßen:

Dim part As SldWorks.ModelDoc2

 

Überprüfen Sie dann Schritt für Schritt, ob Ihre NewNameA-Variable korrekt ist. Es sollte den vollständigen Pfad und nicht nur den Dateinamen enthalten.
Dann, dass die Datei existiert. Sie sollten diesen Fehler auch in Ihrem Code behandeln.

Schönen Tag.

3

Danke @remrem

Also habe ich 'part' durch 'swModel' ersetzt, indem ich es instanziiert habe, und es funktioniert.

Tolle ;)

4

Wie ich vorgeschlagen habe, können Sie das Vorhandensein der Dateien mit dieser Funktion überprüfen:

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

 

1 „Gefällt mir“