J’ai toujours tester sur le même fichier. la mise en plan d’une casquette.
La mise en plan est dans un dossier différents des pièces, mais les fichier ont le même nom.
J’ai déjà regarder le code en le faisant pas-a-pas, et comme je ne m’y connais pas trop je ne sui spas certains de pouvoir identifier correctement les soucis.
Pour lancer la macro je me suis fait un bouton et j’ai aussi essayer avec la touche lecture.
Oui pour les sous-dossier pour le moment je n’ai rien fait pas part collé les 3 variable à définir.
Car j’essaye de faire fonctionne le code à chaque fois. J’ai repris le code bases sans faire de modification à part enlever la Révision dans le nom du fichier.
ça a fonctionner une fois, j’ai supprimer les fichier généré et recommencer et la j’avais l’erreur ci dessous
Et non je n’ai pas encore tester le code de la 4e réponse @Cyril.f
Bonne nouvelle.
Ne reste donc plus qu’à valider la « Meilleur réponse » pour clôturer cette discussion.
Et à bientôt pour de nouvelles macro…
entre-temps, je te conseil de consulter différents sites (pas toujours en français -Visual Basic- oblige) mais souvent didactiques pour se lancer dans la programmation:
Si tu prends le code du 5ème message , il met bien les fichier dans les répertoires pdf Dwg et Step.
Je pense que tu mélanges les pinceaux avec les différents versions de la macro.
Voici l’exemple déjà mis plus haut:
Effectivement autant pour moi je n’ai bien regarder désolé pour tout ces échanges !
J’ai juste une petite remarque, le dossier STEP est crée dans le dossier Mise en plan, et je voudrais qu’il soit crée dans le dossiers pièces. Voici l’arborescence de mes fichiers :
1-Assemblage
2-Pièces / STEP
3-Mise en plan / PDF - /DWG
En ajoutant quelques chose comme cela cela devrait être mieux (non testé):
'On revient un dossier en arrière puis on ajoute le dossier Pièces
sFilePath = Left(sModelFullPath, InStrRev(sModelFullPath, "\"))
sFilePath = sFilePath & "Pièces\"
Surement un \ en trop ou en moins quel est la valeur de sFilePath juste avant?
Au besoin pour la verifier
ajout de debug.print sFilepath, juste en dessous des 3 lignes précédentes et regarder la valeure dans la fenêtre « Execution » via edition de macro affichage
Est-ce que le dossier pièces existe systématiquement et est toujours codifié de la même façon?
En gros pour exemple est-ce ce type d’arborescence?
C:\xxxx\Pièces
C:\xxxx\Mises plans
En gros, non optimisé et pas de vérification si les fichiers existent déjà:
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swView As SldWorks.View
Dim swConfig As SldWorks.Configuration
Dim vSheetNameArr As Variant
Dim vSheetName As Variant
Dim I As Long
Dim nDocType As Long
Dim op As Long
Dim suppr As Long
Dim lErrors As Long
Dim lWarnings As Long
Dim boolstatus As Boolean
Dim bRet As Boolean
Dim FileConnu As Boolean
Dim nbConnu As Integer
Dim sModelName As String
Dim sPathName As String
Dim TabConnu(10000) As String
Dim sConfigName As String
Dim sModelFullPath As String
Dim sFilePath As String
Dim sFilePathStep As String
Dim sFileName As String
Dim sFileNameWithoutExtension As String
Dim fs As Scripting.FileSystemObject
Const dxfSubFolder = "dwg\"
Const pdfSubFolder = "pdf\"
Const stepSubFolder = "2 - Pieces\step\"
Sub main()
Set swApp = Application.SldWorks
boolstatus = swApp.SetUserPreferenceIntegerValue(swStepAP, 214) 'Force la version AP214
boolstatus = swApp.SetUserPreferenceIntegerValue(swStepExportPreference, swAcisOutputGeometryPreference_e.swAcisOutputAsSolidAndSurface) 'Force l'export en format Solid/Surface Geometry
Set swModel = swApp.ActiveDoc
' PathName of current model document
sModelFullPath = swModel.GetPathName
' get path name without filename
sFilePath = Left(sModelFullPath, InStrRev(sModelFullPath, "\"))
sFilePathStep = Left(sFilePath, InStrRev(sFilePath, "\", Len(sFilePath) - 1))
Debug.Print sFilePathStep
' get filename and extension
sFileName = Right(sModelFullPath, Len(sModelFullPath) - InStrRev(sModelFullPath, "\"))
' get filename without extension
sFileNameWithoutExtension = Left(sFileName, InStrRev(sFileName, ".") - 1)
Debug.Print sFilePath & pdfSubFolder & sFileNameWithoutExtension & ".pdf"
'On vérifie si le dossier de sauvegarde existe sinon création de ce dossier
CreateRep (sFilePath & pdfSubFolder)
swModel.Extension.SaveAs sFilePath & pdfSubFolder & sFileNameWithoutExtension & ".pdf", swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, lErrors, lWarnings
'On vérifie si le dossier de sauvegarde existe sinon création de ce dossier
CreateRep (sFilePath & dxfSubFolder)
swModel.Extension.SaveAs sFilePath & dxfSubFolder & sFileNameWithoutExtension & ".dwg", swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, lErrors, lWarnings
'On vérifie si le dossier de sauvegarde existe sinon création de ce dossier
CreateRep (sFilePathStep & stepSubFolder)
Call ExportStep
End Sub
Function CreateRep(sRep As String)
Set fs = New Scripting.FileSystemObject
If Not fs.FolderExists(sRep) Then
fs.CreateFolder (sRep)
End If
Set fs = Nothing
End Function
Sub ExportStep()
Set swDraw = swModel
vSheetName = swDraw.GetSheetNames
vSheetNameArr = swDraw.GetSheetNames
For Each vSheetName In vSheetNameArr
bRet = swDraw.ActivateSheet(vSheetName): Debug.Assert bRet
Set swView = swDraw.GetFirstView 'Sélectionne le fond de plan
Set swView = swView.GetNextView 'Passe à la vue suivante pour exclure le fond de plan
While Not swView Is Nothing
' Determine if this is a view of a part or assembly
sModelName = swView.GetReferencedModelName
sModelName = LCase(sModelName)
sConfigName = swView.ReferencedConfiguration
FileConnu = False
If InStr(sModelName, "sldprt") > 0 Then
nDocType = swDocPART
ElseIf InStr(sModelName, "slasm") > 0 Then
nDocType = swDocASSEMBLY
Else
nDocType = swDocNONE
Exit Sub
End If
If nDocType = 1 Then
For I = 1 To nbConnu
If UCase(sModelName) & " - " & UCase(sConfigName) = TabConnu(I) Then
FileConnu = True
End If
Next
If Not FileConnu Then
nbConnu = nbConnu + 1
TabConnu(nbConnu) = UCase(sModelName) & " - " & UCase(sConfigName)
Call Export
End If
End If
Set swView = swView.GetNextView
Wend
Next vSheetName
End Sub
Sub Export()
Set swModel = swApp.ActivateDoc3(sModelName, True, swOpenDocOptions_Silent, lErrors)
Set swModel = swApp.ActiveDoc
boolstatus = swModel.ShowConfiguration2(sConfigName)
Set swConfig = swModel.GetActiveConfiguration
sPathName = sFilePathStep & stepSubFolder & sFileNameWithoutExtension & ".step"
If Dir(sPathName, vbHidden) <> "" Then 'Test l'existence du fichier
suppr = MsgBox("Le fichier " & sPathName & " existe déjà, voulez vous le supprimer?", vbYesNo) 'Message utilisateur confirmation de suppression oui/non
If suppr = vbYes Then 'Réponse Oui
Kill (sPathName) 'Suppression du fichier existant
swModel.SaveAs2 sPathName, 0, True, False 'Enregistrement du fichier
op = MsgBox("Le fichier a été enregistré sous " & sPathName & vbNewLine)
Else 'Réponse NON
MsgBox ("Fichier conservé") 'Message utilisateur
End If
Else
swModel.SaveAs2 sPathName, 0, True, False 'Enregistrement du fichier
op = MsgBox("Le fichier a été enregistré sous " & sPathName) 'Message utilisateur
End If
swApp.CloseDoc (sModelName)
Set swModel = swApp.ActiveDoc
End Sub
Pour que ça fonctionne faut sélectionner « Microsoft Scripting Runtime » dans les références:
sur cette partie de code je dois changer quoi pour que la macro fonctionne ?
'On revient un dossier en arrière puis on ajoute le dossier Pièces
sFilePath = Left(sModelFullPath, InStrRev(sModelFullPath, "\"))
sFilePath = sFilePath & "2 - Pièces\"
'On vérifie si le dossier de sauvegarde existe sinon création de ce dossier STEP
If Dir(sFilePath & "Step\", vbDirectory) = vbNullString Then
MkDir sFilePath & "Step\"
End If
