bonjour à tous,
je n’ai pas pu revenir vers vous plus tôt mais voici le résultat.
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
Mon code est très certainement optimisable (mais je ne sais pas trop faire) mais il a le mérite de fonctionner.
Merci encore à vous pour votre aide