Bonjour
lien de référence :
http://help.solidworks.com/2015/english/api/sldworksapi/pack_and_go_an_assembly_example_vb.htm
https://excel-malin.com/tutoriels/vba-fonctions/replace/
suite à cette question:( https://www.lynkoa.com/forum/solidworks/macro-packandgo-composition-%C3%A0-emporter ) ,qui correspond à une de mes demande j'ai voulue crée ma petit copie de projet personnelle
mon problème est que :
je fait ma copie de projet tout ce passe mais au moment ou l'on renomme les pièces, j'ai un assemblage "15.VbA.TeSt" : cela va me le renommé "10.vba.test" les majuscule ne suivent pas
'---------------------------------------------------------------------------
'Conditions préalables:
'1. L'assemblage spécifié existe.
'2. Le dossier, c: \ temp, existe.
'3. Ouvrez la fenêtre Immédiate.
'4. Exécutez la macro.
'
'Conditions postales:
'1. Imprime les noms du chemin actuel et les noms de fichiers des documents d'assemblage à la fenêtre Immédiat.
'2. Imprime les noms du chemin par défaut et les noms de fichiers auxquels enregistrer les documents d'assemblage dans la fenêtre Immédiat.
'3. Spécifie le dossier de destination Pack and Go.
'4. Spécifie que tous les fichiers sont enregistrés dans le répertoire racine du Dossier de destination 'Pack and Go'.
'5. Ajoute le préfixe et le suffixe aux noms de fichiers nommés par l'utilisateur.
'6. Imprime le nom du chemin spécifié par l'utilisateur et le nom du fichier nommé «Fenêtre immédiate.
'7. Crée les fichiers nommés par l'utilisateur dans le chemin spécifié par l'utilisateur à l'aide de Pack and Go.
'8. Examinez c: \ temp pour vérifier.
Option Explicit
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim DerligneOuvre As Integer
Dim DerligneFerme As Integer
Dim swApp As SldWorks.SldWorks
Dim swModelDoc As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swPackAndGo As SldWorks.PackAndGo
Dim openFile As String
Dim pgFileNames As Variant
Dim pgFileStatus As Variant
Dim pgGetFileNames As Variant
Dim pgDocumentStatus As Variant
Dim status As Boolean
Dim warnings As Long
Dim errors As Long
Dim i As Long
Dim namesCount As Long
Dim myPath As String
Dim statuses As Variant
Public Function DossierExiste(MonDossier As String)
If Len(Dir(MonDossier, vbDirectory)) > 0 Then
DossierExiste = True
Else
DossierExiste = False
End If
End Function
Private Sub CommandButton1_Click()
If TextBox1.Value = "" Then
MsgBox "mettre un numero de dossier"
Exit Sub
End If
'creer un repertoire affaire
Dim MonDossier As String
Sheets("BD_copie").Range("F2") = TextBox1.Value
MonDossier = Sheets("BD_copie").Range("F4")
If DossierExiste(MonDossier) = True Then
MsgBox "Le dossier existe... prendre un numero non utiliser"
Exit Sub
Else
MsgBox "dossier creer..."
MkDir Sheets("BD_copie").Range("F4")
End If
'-------------------------------------------------------------------------------------------------------------------------------------------------------
Set swApp = CreateObject("SldWorks.application")
Set swModelDoc = swApp.ActiveDoc
Set swModelDocExt = swModelDoc.Extension
' Get Pack and Go object
Set swPackAndGo = swModelDocExt.GetPackAndGo
' Get number of documents in assembly
namesCount = swPackAndGo.GetDocumentNamesCount
Debug.Print " Number of model documents: " & namesCount
' Include any drawings, SOLIDWORKS Simulation results, and SOLIDWORKS Toolbox components
swPackAndGo.IncludeDrawings = True
swPackAndGo.IncludeSimulationResults = False
swPackAndGo.IncludeToolboxComponents = False
' Get current paths and filenames of the assembly's documents
status = swPackAndGo.GetDocumentNames(pgFileNames)
Debug.Print ""
Debug.Print " Current path and filenames: "
If (Not (IsEmpty(pgFileNames))) Then
For i = 0 To UBound(pgFileNames)
Debug.Print " The path and filename is: " & pgFileNames(i)
Next i
End If
' Get current save-to paths and filenames of the assembly's documents
status = swPackAndGo.GetDocumentSaveToNames(pgFileNames, pgFileStatus)
Debug.Print " Current default save-to filenames: "
If (Not (IsEmpty(pgFileNames))) Then
For i = 0 To UBound(pgFileNames)
Debug.Print " The path and filename is: " & pgFileNames(i)
Next i
End If
' Set document paths and names for Pack and Go
For i = 0 To (namesCount - 1)
If InStr(pgFileNames(i), Sheets("BD_copie").Range("E2")) <> 0 Then
' fonction replace : https://excel-malin.com/tutoriels/vba-fonctions/replace/
pgFileNames(i) = Replace(pgFileNames(i), Sheets("BD_copie").Range("E2"), Sheets("BD_copie").Range("F2"), 1, 1)
Else
pgFileNames(i) = ""
End If
Next i
status = swPackAndGo.SetDocumentSaveToNames(pgFileNames)
' Set folder where to save the files
myPath = Sheets("BD_copie").Range("F4")
status = swPackAndGo.SetSaveToName(True, myPath)
' Flatten the Pack and Go folder structure; save all files to the root directory
swPackAndGo.FlattenToSingleFolder = True
' Pack and Go
statuses = swModelDocExt.SavePackAndGo(swPackAndGo)
pouvez vous m'aider ??