Fensterwechsel

erik.a · 18. Oktober 2023 um 07:02

Hallo ihr alle

In einem Makro, das aus einer Bauteil- oder Baugruppendatei gestartet wird, öffne ich den zugehörigen Plan. Dann erstelle ich einen neuen Dateinamen, um unter 2 Dateien zu speichern. Prozess unten

Öffnen des Plans
Zurück zur Teile-/Baugruppendatei
Speichern unter mit dem neuen Dateinamen
Auswählen des Fensters "Plan"
Speichern unter mit dem neuen Dateinamen

Ich weiß nicht, wie ich mit dem Schalten von Fenstern umgehen soll (Schritt 2 und 4)

Würde jemand wissen, wie man das macht? Ich kann im Internet nichts finden

Vielen Dank im Voraus

sbadenis · 18. Oktober 2023 um 07:35

Meiner Meinung nach gibt es mehrere Möglichkeiten, Ihr Geschäft zu führen:
Kopieren Sie den Plan mit FSO und ändern Sie die Planreferenz

Verwenden Sie die Pack and Go-Funktion...
Können Sie Ihren vorhandenen Code zeigen, wird es einfacher sein.
Ansonsten so etwas wie:
Set Part = swApp.OpenDoc6(Datei, 3, 0, " ", longstatus, longwarnings)
Set swDraw = swApp.OpenDoc6(Datei, 3, 0, " ", longstatus, longwarnings)
Öffnet das Teil oder die Zeichnung nach Bedarf

Cyril.f · 18. Oktober 2023 um 07:35

Hallo
Beispiel für das Wechseln von Dokumenten (VBA) - 2022 - SOLIDWORKS API-Hilfe

Maclane · 18. Oktober 2023 um 08:32

Auf dem von @sbadenis vorgeschlagenen Makro habe ich eine Funktion hinzugefügt, um die Auswahl von Komponenten aus einer Wiederholung zu verhindern... (Das warf einige Probleme auf...)

'*****************************************************************************************************************************
'On determine si le composant selectionné fait partie d'une repetition ou non...

Dim swCompPatterned As String
swCompPatterned = swComp.IsPatternInstance() 'TRUE Si le composant fait partie d'une repetition FALSE si ce n'est pas le cas
If swCompPatterned = "Vrai" Then
MsgBox ("Erreur, le composant selectionné fait partie d'une repetition."), vbOKOnly, "Erreur -> Repetition..."
Exit Function
End If
'*****************************************************************************************************************************

Abgesehen von dieser persönlichen Ergänzung ist dieses Makro zu einem "Muss" für unser Designdesign geworden.

Herzliche Grüße.

erik.a · 18. Oktober 2023 um 08:44

Vielen Dank an alle für Ihre Antworten.

Hier ist mein Code für jetzt. Es gibt einen großen Block, der es Ihnen ermöglicht, den Namen der Datei, unter der gespeichert werden soll, mit dem neuen Index zu rekonstituieren (ja nein PDM , der Index unserer Teile befindet sich im Dateinamen)

Dim swApp As Object

Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long

Sub NouvelleRev()

Dim swApp           As SldWorks.SldWorks
Dim swModel         As SldWorks.ModelDoc2
Dim Filepath           As String
Dim FileName           As String
Dim FileName2          As String
Dim FileName3          As String
Dim FilepathDrw        As String
Dim RevFile            As String

Dim NomFichierPlan     As String
Dim NomFichierPiece    As String

Dim ExtFichier         As String

Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc

'******************************************************
' Contrôle du type de fichier ouvert
'******************************************************

If (swModel Is Nothing) Or (swModel.GetType = 3) Then

    swApp.SendMsgToUser ("Macro utilisable à partir d'une pièce ou d'un assemblage uniquement.")
    
     'Si mauvais format de fichier ouvert alors on ferme la macro
    Exit Sub

End If

'******************************************************
' Ouverture du plan associé à la pièce/asm concerné
'******************************************************

Filepath = swModel.GetPathName
FileName = Right(Filepath, Len(Filepath) - InStrRev(Filepath, "\"))

If swModel.GetType = 1 Then 'fichier pièce
    FileName2 = Replace(FileName, ".SLDPRT", ".SLDDRW")
ElseIf swModel.GetType = 2 Then 'fichier assemblage
    FileName2 = Replace(FileName, ".SLDASM", ".SLDDRW")
End If

FilepathEnCours = Replace(Filepath, FileName, "")
FilepathDrw = FilepathEnCours & FileName2

'Indice du plan
If swModel.GetType = 1 Then 'fichier pièce
    FileName = Replace(FileName, ".SLDPRT", "")
ElseIf swModel.GetType = 2 Then 'fichier assemblage
    FileName = Replace(FileName, ".SLDASM", "")
End If

RevFile = Right(FileName, Len(FileName) - InStrRev(FileName, "-"))

'Ouverture du plan associée au document ouvert
Set Part = swApp.OpenDoc6(FilepathDrw, 3, 192, "", longstatus, longwarnings)

'******************************************************
' Nouvel Indice
'******************************************************
Dim NewRevFile As String
NewRevFile = Chr(Asc(RevFile) + 1)


'******************************************************
' Enregister sous du fichier pièce
'******************************************************
'Création du nom du fichier pour la fonction "enregistrer sous"
FileName3 = Left(FileName, 7)

If swModel.GetType = 1 Then 'fichier pièce
    ExtFichier = ".SLDPRT"
ElseIf swModel.GetType = 2 Then 'fichier assemblage
    ExtFichier = ".SLDASM"
End If

'Nom du fichier plan final
NomFichierPlan = FilepathEnCours & FileName3 & "-" & NewRevFile & ExtFichier

' Enregistrer sous nouvelle révision du fichier pièce
longstatus = Part.SaveAs3(NomFichier, 0, 0)

'******************************************************
' Enregister sous du fichier plan
'******************************************************
'Création du nom du fichier pour la fonction "enregistrer sous"
FileName3 = Left(FileName, 7)

Dim ExtFichierPlan As String

If swModel.GetType = 3 Then 'fichier plan
    ExtFichierPlan = ".SLDDRW"
End If

'Nom du fichier plan final
NomFichierPlan = FilepathEnCours & FileName3 & "-" & NewRevFile & ExtFichierPlan

' Enregistrer sous nouvelle révision du fichier pièce
longstatus = Part.SaveAs3(NomFichier, 0, 0)

End Sub

Ich werde Ihren Vorschlag sofort testen @sbadenis

sbadenis · 18. Oktober 2023 um 08:50

Für den Tipp verwende ich auch ein Makro, hier ist der Teil, der Sie interessieren könnte, ich bin mir nicht sicher, ob es der sauberste Code ist, aber er ist perfekt funktionsfähig, ich setze Ihnen nur den nützlichen Teil ein, weil ich eine schreibgeschützte Einstellung des angedeuteten Stücks habe, ich verstecke den alten Hinweis und übergebe ihn auch in einer bestimmten Farbe, also hänge ich Ihnen nur den interessanten Teil an:

Function incrementationIndicePlan()
    Debug.Print "   Function incrementationIndicePlan lancé"
   'on vérifie si un indice est existant et on sauvegarde l'ancien
    OldIndice = Indice
    Debug.Print "OldIndice:" & OldIndice
    'Maj 2023-06-12 Si Indice = " " on force l'Indice pour avoir la valeur A
    If Indice = "" Or Indice = " " Then
        Indice = "A"
        Debug.Print "Indice non existant- Indice passe à:" + Indice
        Debug.Print "OldIndice:" & OldIndice
        Else
        Indice = Chr$(Asc(Indice) + 1)
        Debug.Print "Indice:" + Indice
        Debug.Print "OldIndice:" & OldIndice
    End If
    
    Set fso = VBA.CreateObject("Scripting.FileSystemObject")
    path = Filepath + Compteur + Indice + Extension
    Debug.Print "Path:"; path
    'On vérifie que l'indice que l'on veux créer n'existe pas déjà
     If Dir(path) <> "" Then
     MsgBox "Le fichier " & path & " existe déjà. Création de cet Indice refusé."
     End
     End If
    
    'on modifie les propriétées Indice et Nom_Fichier
    Set swCustProp = swModel.Extension.CustomPropertyManager("")
    bRet = swCustProp.Add3("Indice", swCustomInfoType_e.swCustomInfoText, Indice, swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd)
    Debug.Print "Propriété Indice:" & Indice
    bRet = swCustProp.Add3("Nom_Fichier", swCustomInfoType_e.swCustomInfoText, Compteur + Indice, swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd)
    'Debug.Print "Propriété Nom_Fichier:" & Compteur + Indice
    
    'On enregistre la nouvelle pièce ou assemblage
    swModel.SaveAs3 "" & path & "", 0, 0
    
    'On vérifie l'existance de la MEP associé
    PathMep = Filepath + Compteur
    Debug.Print Filepath + Compteur & OldIndice; ".SLDDRW"
    If Dir(PathMep & OldIndice & ".SLDDRW") <> "" Then
        Call fso.CopyFile(PathMep & OldIndice & ".SLDDRW", PathMep & Indice & ".SLDDRW")
        Set swApp = Application.SldWorks
        'On change la référence du nouveau plan par la pièce ou assemblage avec le nouvel Indice
        Call swApp.ReplaceReferencedDocument(PathMep & Indice & ".SLDDRW", PathMep & OldIndice & Extension, PathMep & Indice & Extension)
    Else
    Debug.Print "Pas de Mep"
    End If
   
    
End Function

erik.a · 24. Oktober 2023 um 12:05

Hallo ihr alle

Ich konnte mich nicht früher bei Ihnen melden, aber hier ist das Ergebnis.

Dim swApp As Object

Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long

Sub NouvelleRev()

Dim swApp           As SldWorks.SldWorks
Dim swModel         As SldWorks.ModelDoc2
Dim Filepath           As String
Dim FileName           As String
Dim FileName2          As String
Dim FileName3          As String
Dim FilepathDrw        As String
Dim RevFile            As String
Dim FilepathEnCours As String

Dim NomFichierPlan     As String
Dim NomFichierPiece    As String

Dim ExtFichier         As String

Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc

'******************************************************
' Contrôle du type de fichier ouvert
'******************************************************

If (swModel Is Nothing) Or (swModel.GetType = 3) Then

    swApp.SendMsgToUser ("Macro utilisable à partir d'une pièce ou d'un assemblage uniquement.")
    
     'Si mauvais format de fichier ouvert alors on ferme la macro
    Exit Sub

End If

'******************************************************
' Ouverture du plan associé à la pièce/asm concerné
'******************************************************

Filepath = swModel.GetPathName
FileName = Right(Filepath, Len(Filepath) - InStrRev(Filepath, "\"))

    If swModel.GetType = 1 Then 'fichier pièce
            FileName2 = Replace(FileName, ".SLDPRT", ".SLDDRW")
        ElseIf swModel.GetType = 2 Then 'fichier assemblage
            FileName2 = Replace(FileName, ".SLDASM", ".SLDDRW")
    End If

FilepathEnCours = Replace(Filepath, FileName, "")
FilepathDrw = FilepathEnCours & FileName2

'Indice du plan
    If swModel.GetType = 1 Then 'fichier pièce
            FileName = Replace(FileName, ".SLDPRT", "")
        ElseIf swModel.GetType = 2 Then 'fichier assemblage
            FileName = Replace(FileName, ".SLDASM", "")
    End If

RevFile = Right(FileName, Len(FileName) - InStrRev(FileName, "-"))

'Ouverture du plan associée au document ouvert
Set Part = swApp.OpenDoc6(FilepathDrw, 3, 1, "", longstatus, longwarnings)

If Part Is Nothing Then

MsgBox "Il n'existe pas de plan associé à ce fichier!"

Exit Sub

End If

'******************************************************
' Nouvel Indice
'******************************************************
Dim NewRevFile As String
NewRevFile = Chr(Asc(RevFile) + 1)


'******************************************************
' Enregistrement sous du fichier pièce

Set swDraw = swApp.OpenDoc6(Filepath, 1, 128, "", longstatus, longwarnings)

'Création du nom du fichier pour la fonction "enregistrer sous"
FileName3 = Left(FileName, 7)

    If swModel.GetType = 1 Then 'fichier pièce
            ExtFichier = ".SLDPRT"
        ElseIf swModel.GetType = 2 Then 'fichier assemblage
            ExtFichier = ".SLDASM"
    End If

Dim NomFichier3D As String

NomFichier3D = FilepathEnCours & FileName3 & "-" & NewRevFile & ExtFichier


Dim EnregistrementFichier As Long

' Enregistrer sous nouvelle révision du fichier pièce
EnregistrementFichier = swModel.SaveAs3(NomFichier3D, 0, 0)

Call EnregistrementPlan

MsgBox "Job done!"

End Sub

Sub EnregistrementPlan()

Dim swApp           As SldWorks.SldWorks
Dim swModel         As SldWorks.ModelDoc2
Dim Filepath           As String
Dim FileName           As String
Dim FileName2          As String

Dim FilepathDrw        As String
Dim RevFile            As String
Dim FilepathEnCours As String

Dim NomFichierPlan     As String

Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc

Set swDraw = swApp.OpenDoc6(Filepath, 3, 192, "", longstatus, longwarnings)

'Nom du fichier
Filepath = swModel.GetPathName
FileName = Right(Filepath, Len(Filepath) - InStrRev(Filepath, "\"))

FilepathEnCours = Replace(Filepath, FileName, "")

'******************************************************
' Nouvel Indice
'******************************************************
RevFile = Right(FileName, Len(FileName) - InStrRev(FileName, "-"))
Dim NewRevFile As String
NewRevFile = Chr(Asc(RevFile) + 1)


'Nom du fichier
FileName2 = Left(FileName, 7)
NomFichierPlan = FilepathEnCours & FileName2 & "-" & NewRevFile & ".SLDDRW"



Dim EnregistrementFichier As Long

EnregistrementFichier = swModel.SaveAs3(NomFichierPlan, 0, 512)

End Sub

Mein Code ist sicherlich optimierbar (aber ich weiß nicht wirklich, wie ich es machen soll), aber er hat den Vorteil, dass er funktioniert.

Nochmals vielen Dank für Ihre Hilfe