Im Anhang befindet sich der geänderte Code, ich bin mir nicht sicher, ob er der sauberste ist, aber er scheint funktionsfähig zu sein.
Wenn der Pfad leer ist, wird ein Verzeichnis erstellt, das in der 3. Zeile definiert ist (harter Pfad kann bei Bedarf geändert werden) Hier "C:\Temp\AS_STEP\"
Alle Ihre Schrittdateien werden daher in diesen Ordner kopiert und können durch Schließen der Baugruppe verschoben werden. (Kopieren und Einfügen aus Ordner)
Es gibt eine Möglichkeit, Sie dazu zu bringen, den Zielpfad zu wählen, aber ich weiß nicht mehr, wie, also ist hier die Lösung, die als Ersatz gewählt wird.
Option Explicit
'On définit la constant pour le chemin si assemblage non eregistré
Public Const CheminConstante As String = "C:\Temp\AS_STEP\"
Sub TraitementAssemblage(swComp As SldWorks.Component2, ByVal Emplacement As String, ByVal nomfichier As String)
Dim vChildComp As Variant
Dim swModelComponent As SldWorks.ModelDoc2
Dim swChildComp As SldWorks.Component2
Dim swCompConfig As SldWorks.Configuration
Dim nChild As Long
Dim longStatus As Boolean
Dim dossier As String
dossier = Emplacement & Left(nomfichier, Len(nomfichier) - 7) & "\" ' Nom de dossier: celui de l'assemblage
If Dir(dossier, vbDirectory) = "" Then
MkDir dossier ' Création du dossier de l'assemblage
Set swModelComponent = swComp.GetModelDoc2
longStatus = swModelComponent.SaveAs3(dossier & nomfichier, 0, 0) ' Enregistrement de l'assemblage dans son dossier
Else
Exit Sub
End If
vChildComp = swComp.GetChildren ' Liste des enfants de l'assemblage
For nChild = 0 To UBound(vChildComp)
Set swChildComp = vChildComp(nChild)
nomfichier = Dir$(swChildComp.GetPathName)
If UCase(Right(nomfichier, 6)) = "SLDASM" Then ' Si c'est un assemblage: traitement récursif
TraitementAssemblage swChildComp, dossier, nomfichier
ElseIf UCase(Right(nomfichier, 6)) = "SLDPRT" Then ' si c'est une pièce : enregistrement
Set swModelComponent = swChildComp.GetModelDoc2
longStatus = swModelComponent.SaveAs3(dossier & nomfichier, 0, 0)
End If
Next nChild
End Sub
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swConf As SldWorks.Configuration
Dim swRootComp As SldWorks.Component2
Dim Emplacement As String
Dim nomfichier As String
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Emplacement = swModel.GetPathName
'On vérifie l'extension
Dim FileTyp As Long
FileTyp = swModel.GetType
If Not FileTyp = swDocASSEMBLY Then
MsgBox ("Le document doit être un assemblage...")
Exit Sub
End If
If Emplacement = "" Then
If Not Len(Dir(CheminConstante, vbDirectory)) > 0 Then
MkDir CheminConstante
Emplacement = CheminConstante
Debug.Print swModel.GetTitle
nomfichier = swModel.GetTitle & ".sldasm"
Else
nomfichier = swModel.GetTitle & ".sldasm"
Emplacement = CheminConstante
End If
Else
nomfichier = Dir$(Emplacement) ' Nom du document d'assemblage principal
End If
Debug.Print Emplacement
'If Right(Emplacement, 1) = "\" Then Emplacement = Left(Emplacement, Len(Emplacement) - 1)
'Emplacement = Left(Emplacement, InStrRev(Emplacement, "\")) ' Nom du dossier d'origine
Set swConf = swModel.GetActiveConfiguration
Set swRootComp = swConf.GetRootComponent3(False)
TraitementAssemblage swRootComp, Emplacement, nomfichier ' Comme c'est un assemblage: traitement
swModel.Extension.SaveAs Emplacement & nomfichier, swSaveAsVersion_e.swSaveAsCurrentVersion, swSaveAsOptions_e.swSaveAsOptions_Silent, Nothing, 0, 0
End Sub
Seien Sie vorsichtig, dieses Makro funktioniert nicht, wenn Sie 3Dinterconnect importieren, es sei denn, Sie unterbrechen die Verknüpfung.