VBA - Enregistrer sous automatique de mise en plan

actixxx · Juillet 27, 2016, 9:53

Bonjour, j'aimerais réaliser une mep qui à partir d'une pièce, ouvre sa mise en plan et enregistre sous la pièce et la mep sous le même nom. J'ai réalisé le code ci-dessous, en la testant, les variables sont bonnes mais ça ne fonctionne pas ...

Merci pour votre aide :)

Sub main()

Set swApp = _

Application.SldWorks

Set swModel = swApp.ActiveDoc

FilePath = swModel.GetPathName

TitleP = swModel.GetTitle

PathSize = Len(FilePath)

PathNoExtension = Left(FilePath, PathSize - 7)

PathMEP = PathNoExtension & ".SLDDRW"

TitleSize = Len(TitleP)

TitleNoExtension = Left(TitleP, TitleSize - 7)

TitleMEP = TitleNoExtension & " - Feuille1"

Set Part = swApp.OpenDoc6(PathMEP, 2, 0, "", longstatus, longwarnings) 'ouverture de l'assemblage source'

swApp.ActivateDoc2 TitleMEP, False, longstatus

Set Part = swApp.ActiveDoc 'activation'

Set swApp = Application.SldWorks

Set swModel = swApp.ActiveDoc

bool = swModel.Extension.RunCommand(SwCommands.swCommands_SaveAs, "")

Set swModel = swApp.ActiveDoc

'Récupère le nom complet du fichier

FilePath = swModel.GetPathName

PathSize = Len(FilePath)

PathNoExtension = Left(FilePath, PathSize - 6)

PathMEP = PathNoExtension & ".SLDDRW"

Set Part = swApp.ActiveDoc

longstatus = Part.SaveAs3(FilePathMEP, 0, 2)

End Sub

pl · Juillet 27, 2016, 9:55

Bonjour,

Je te conseille de regarder la macro enregistrer sous que j'ai mise en tutoriel sur Lynkoa :

http://www.lynkoa.com/tutos/3d/macro-enregistrer-sous-avec-solidworks

Elle fait ce que tu demandes et chaque ligne est commentée.

actixxx · Juillet 27, 2016, 10:34

Est-il possible d'avoir le code directement sous format macro s'il te plaît ? Ca sera plus lisible :)

pl · Juillet 27, 2016, 12:18

Le code est disponible dans le lien, mais si tu préfères comme ça, voilà :

'19/03/2012 16:46 fonctionne mais uniquement si DRW a le même nom dans le même dossier
Sub ENREGISTRER() 'save as
Dim swApp As SldWorks.SldWorks
Dim SWmoddoc As SldWorks.ModelDoc2
Dim CODE As String
Dim nErrors As Long
Dim nWarnings As Long
Set swApp = Application.SldWorks
Set SWmoddoc = swApp.ActiveDoc
'obtient le chemin complet du document actif, y compris le nom du fichier :
PathName = UCase(SWmoddoc.GetPathName)
'vérification qu'on n'est pas sur un drw = 2D :
If Right(PathName, 3) = "DRW" Then
MesgBOX = MsgBox("Macro à lancer uniquement depuis une pièce ou un assemblage", vbMsgBoxSetForeground, "Enregistrer-sous (Par LPR)")
Exit Sub
ElseIf Right(PathName, 3) = "PRT" Then
DRWPath = Replace(PathName, "PRT", "DRW")
ElseIf Right(PathName, 3) = "ASM" Then
DRWPath = Replace(PathName, "ASM", "DRW")
End If
'obtient le chemin du document actif, sans le nom du fichier :
FilePath = Left(PathName, InStrRev(PathName, "\"))
'obtient le nom du fichier :
FileName = Right(PathName, Len(PathName) - InStrRev(PathName, "\"))
'récupère la propriété personnalisée (=CustomInfo) CODE (CustomInfo) =>SPECIFIQUE CODE :
CODE = SWmoddoc.CustomInfo("code")
If CODE = "" Then
'si le code n'existe pas, récupère les 8 premiers caractères du fichier =>SPECIFIQUE CODE & 8 caractères
CODE = Left(Replace(FileName, " ", ""), 8)
End If
'récupère la désignation du fichier (libelleFR chez nous) =>SPECIFIQUE LibelleFR :
libelleFR = SWmoddoc.CustomInfo("libelleFR")
If libelleFR = "" Then
' récupère le libellé en fonction du nom de fichier -7 caractère = extension (.SLDASM par exemple) =>SPECIFIQUE LibelleFR :
libelleFR = Left(Right(FileName, Len(FileName) - InStr(FileName, "-")), Len(Right(FileName, Len(FileName) - InStr(FileName, "-"))) - 7)
End If
'Message de demande de confirmation :
RET = MsgBox("Voulez-vous créer une copie de cette pièce (ou assemblage) et de sa mise en plan sous un nouveau code ?" & vbNewLine & vbNewLine & "ATTENTION : le fichier sera remplacé dans TOUS les fichiers SolidWorks ouverts !", vbOKCancel + vbExclamation + vbMsgBoxSetForeground + vbSystemModal, "Enregistrer-sous (Par LPR)")
'Si annuler : fin du programme :
If RET = vbCancel Then End

pl · Juillet 27, 2016, 12:19

'Si le drw (=2D) existe :
If Dir$(DRWPath) <> "" Then
   'alors on l'ouvre :
Set ouvrir = swApp.OpenDoc6(DRWPath, swDocDRAWING, swOpenDocOptions_Silent, "", nErrors, nWarnings) 'ouvre le DRW dans le même dossier
DRWNull = 0
Else
   'ou on prévient qu'elle n'existe pas dans le même dossier :
DRWNull = MsgBox("La mise en plan est introuvable, soit :" & vbNewLine & vbNewLine & "- le nom est différent du 3D" & vbNewLine & "- le dossier est différent du 3D" & vbNewLine & "- la mise en plan n'existe pas" & vbNewLine & vbNewLine & "Voulez-vous continuer ?", vbOKCancel + vbExclamation + vbMsgBoxSetForeground + vbSystemModal, "Enregistrer-sous (Par LPR)")
   ' on quitte le programme
If DRWNull = 2 Then Exit Sub
End If
'Tant que (renseignement du nouveau code) :
Do
   'le nouveau code n'est pas renseigné =>SPECIFIQUE CODE proposé par défaut :
NewCode = InputBox("Pour ce faire, merci d'indiquer le nouveau code : ", "Enregistrer-sous (Par LPR)", CODE)
   'si on annule :
   If StrPtr(NewCode) = 0 Then
       MsgBox "Procédure annulée"
       'on quitte :
       Exit Sub
   End If
   'Vérifie si le code est numérique =>SPECIFIQUE CODE uniquement numérique :
   Do While IsNumeric(NewCode) = False And MessageBox <> "6"
       MessageBox = MsgBox("Attention, votre code n'est pas unquement numérique !" & vbNewLine & "Est-ce intentionnel ?", vbYesNo)
       If MessageBox = vbNo Then NewCode = InputBox("Pour enregistrer-sous, merci d'indiquer le nouveau code sans espace : ", "Enregistrer-sous par LPR", NewCode)
   Loop
'boucle do, tant que le code n'a pas 8 caractères =>SPECIFIQUE CODE à 8 caractères
Loop While Len(NewCode) <> 8
'Tant que (renseignement du nouveau nom = libelleFR) :
Do
   'quel est le nouveau nom ? =>SPECIFIQUE libelleFR proposé par défaut :
NewName = InputBox("Merci d'indiquer le nouveau nom : " & vbNewLine & vbNewLine & "Pensez à écrire en majuscule", "Enregistrer-sous par LPR", libelleFR)
   'si on annule :
   If StrPtr(NewName) = 0 Then
       MsgBox "Procédure annulée"
       'on quitte :
       Exit Sub
   End If
   'Vérifie si dans le nom il y a des caractères interdit dans Windows " \ / : * ? > < |
   Do While InStr(NewName, Chr(34)) > 0 Or InStr(NewName, "\") > 0 Or InStr(NewName, "/") > 0 _
   Or InStr(NewName, ":") > 0 Or InStr(NewName, "*") > 0 Or InStr(NewName, "?") > 0 Or InStr(NewName, "<") > 0 Or InStr(NewName, ">") > 0 Or InStr(NewName, "|") > 0
       'pérvient d'un caractère interdit
       NewName = InputBox("Attention, le nom contient au moins un des caractère interdits \/:*?""<>|" & vbNewLine & vbNewLine & _
       "Merci d'indiquer le nouveau nom : ", "Enregistrer-sous par LPR", NewName)
   Loop
'Boucle Do, tant que le nouveau nom est vide
Loop While NewName = ""

pl · Juillet 27, 2016, 12:19

'Tant que (renseignement du chemin ou enregistrer = pathname) :
Do
   'quel est le chemin ?
FilePath = InputBox("" & vbNewLine & " ", "Enregistrer-sous par LPR", FilePath)
   If StrPtr(FilePath) = 0 Then
       MsgBox "Procédure annulée"
       Exit Sub
   End If
   'ajout un \ à la fin s'il n'y est pas :
   If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
   'vérifie l'existence d'un fichier ou répertoire :
   If Dir$(FilePath) <> "" Then
       EXISTE = 1
   Else: MsgBox "Le répertoir n'existe pas, merci de le créer"
   Debug.Print Dir$(FilePath)
   End If
'Boucle Do, tant que le répertoire renseigné n'existe pas :
Loop While EXISTE <> 1
'réactive le document 3D :
Set swModel = swApp.ActivateDoc2(PathName, False, nErrors)
'si c'est un assemblage :
If (SWmoddoc.GetType = swDocASSEMBLY) Then
   'enregistrement sous CHEMIN & NewCode & tiret & NewName & .SLDASM
   '=>SPECIFIQUE CODE-NOM
   'exemple tous nos fichiers sont ainsi :
   '33333333-DESIGNATION DU FICHIER.extension
   'c'est à dire
   '[8 caractères] [tiret du 6] [désignation du fichier]
SWmoddoc.SAVEAS (FilePath + NewCode + "-" + NewName + ".SLDASM")
ElseIf (SWmoddoc.GetType = swDocPART) Then
   'enregistrement pour SLDPRT =>SPECIFIQUE idem au dessus
SWmoddoc.SAVEAS (FilePath + NewCode + "-" + NewName + ".SLDPRT")
End If
'ajoute la propriété personnalisée CODE (=>SPECIFIQUE CODE) :
retval = SWmoddoc.AddCustomInfo3("", "CODE", 30, NewCode)
SWmoddoc.CustomInfo("CODE") = NewCode
'ajoute la propriété personnalisée libelleFR (=>SPECIFIQUE libelleFR) :
retval = SWmoddoc.AddCustomInfo3("", "libelleFR", 30, NewName)
SWmoddoc.CustomInfo("libelleFR") = NewName
'ajoute la propriété personnalisée nomfichier (=>SPECIFIQUE nomfichier) :
retval = SWmoddoc.AddCustomInfo3("", "nomfichier", 30, NewCode & "-" & NewName)
SWmoddoc.CustomInfo("nomfichier") = NewCode & "-" & NewName
'ajoute la propriété personnalisée Fichier original (=>SPECIFIQUE Fichier original : je vous conseille de garder celle-ci, ainsi vous aurez toujours l'info dans les propriétés du 3D) :
retval = SWmoddoc.AddCustomInfo3("", "Fichier original", 30, PathName)
SWmoddoc.CustomInfo("Fichier original") = PathName
'Teste que le DRW (2D) existe :
If DRWNull = 0 Then
   'Active le DRW (2D) :
Set SWmoddoc = swApp.ActivateDoc2(DRWPath, False, nErrors)
   'Si c'est bien un DRW (2D) :
If SWmoddoc.GetType = swDocDRAWING Then
   'enregistrer sous (voir commentaires lignes 110 à 115 =>SPECIFIQUE CODE-NOM)
SWmoddoc.SAVEAS (FilePath + NewCode + "-" + NewName + ".SLDDRW")
       'supprime les tables de révisions insérées =>SPECIFIQUE Tables de révisions
For i = 1 To 6
boolstatus = SWmoddoc.Extension.SelectByID2("Table de révisions" & i, "REVISIONTABLEFEAT", 0, 0, 0, False, 0, Nothing, 0)
SWmoddoc.EditDelete
Set currentSheet = SWmoddoc.GetCurrentSheet()
Set myRevisionTable = currentSheet.InsertRevisionTable(True, 0, 0, 3, "\\nas01\DOSSIER\Table de révision détail.sldrevtbt")
Next i
End If
End If
End Sub

actixxx · Juillet 28, 2016, 12:07

Parfait en adaptant ton code ça fonctionne parfaitement :)

Merci encore une fois !