Bonjour Excusé moi de revenir sur ce sujet j'etais absent 2 mois et le topic que j'avais ouvert n'est pas résolue .
J'ai un problème sur un boue de macro.
Lorsque je l'utilise j'ai un fichier nommées XXXXXD05 et lorsque je copie celui ci via ma macro il se transforme en xxxxxd05 .
c'est comme ci j'avais un fichier nommées "OrAngE" et que je l'enregistré sous le nom "orange", mais je ne trouve pas comment lui dire de garder le format d'origine.
J'ai bien essayer de mettre un compare text mais cela ne change rien
voici un bout de ma macro.
Option Explicit
Option Compare Text ' ne prend pas compte du fait des majuscule "XXXXX"="xxxxx"
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
Dim oFSO As Scripting.FileSystemObject
Dim oDrv As Drive
Dim oFl As Folder
Public Function DossierExiste(MonDossier As String)
If Len(Dir(MonDossier, vbDirectory)) > 0 Then
DossierExiste = True
Else
DossierExiste = False
End If
End Function
' ----------------------------------------------------création dossier---------------------------------------------------------------------------------
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("CopieDeProjet").Range("F2") = TextBox1.value
MonDossier = Sheets("CopieDeProjet").Range("F4")
If DossierExiste(MonDossier) = True Then
MsgBox "Le dossier existe... prendre un numero non utiliser"
Exit Sub
Else
MsgBox "dossier creer..."
MkDir Sheets("CopieDeProjet").Range("F4")
End If
'----------------------------------------------------enregistrement assemblage-----------------------------------------------------------------------------------------
Set swApp = CreateObject("SldWorks.application")
Set Part = swApp.ActiveDoc
boolstatus = Part.ForceRebuild3(True)
boolstatus = Part.Save2(False)
Set swModelDoc = swApp.ActiveDoc
Set swModelDocExt = swModelDoc.Extension
Part.ClearSelection2 True
Part.EditRebuild3
'---------------------------------------------------------debut copie-----------------------------------------------------------------------------------------------------
Set swApp = CreateObject("SldWorks.Application")
' Get Pack and Go object
Set swPackAndGo = swModelDocExt.GetPackAndGo
' Get number of documents in assembly
namesCount = swPackAndGo.GetDocumentNamesCount
' Include any drawings, SOLIDWORKS Simulation results, and SOLIDWORKS Toolbox components
swPackAndGo.IncludeDrawings = True
swPackAndGo.IncludeSimulationResults = False
swPackAndGo.IncludeToolboxComponents = False
' Get current save-to paths and filenames of the assembly's documents
status = swPackAndGo.GetDocumentSaveToNames(pgFileNames, pgFileStatus)
' Set document paths and names for Pack and Go
For i = 0 To (namesCount - 1)
If InStr(pgFileNames(i), "34980") <> 0 Then
pgFileNames(i) = Replace(pgFileNames(i), "34980", "34950")
Else
pgFileNames(i) = ""
End If
Next i
status = swPackAndGo.SetDocumentSaveToNames(pgFileNames)
' Set folder where to save the files
myPath = " chemin du dossier "
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)
End sub
après quelques tests j'ai l'impression que cela va être difficile à résoudre via les fonctions issues de "GetPackAndGo", la fonction "GetDocumentNames" semble retourner des noms qui sont systématiquement en minuscules ...
Pour info une composition à emporté à toujours changé la casse des nom de fichier et cela depuis la version 2004 de mémoire ou il changeait déjà les extension de SLDPRT en sldprt. Tout cela de mémoire mais je sais que l'on était embêter à l'époque avec un logiciel de la suite MYCAD qui lui contrairement à windows faisait la différence entre ces 2 casse d'extension.
D'accord merci pour l'information c'est toujours utile de mon coté actuellement nous avons " launch copié de projet" qui garde la casse des pièces en remplaçant les 5 premiers caractères par 5 autres, cela peut m'intéresser c'est pour cela que je suppose que je peux jouer avec la fonction "Replace" mais je ne sais pas comment.
c'est pour cela que je me demande si GetDocumentSaveToNames ne tien pas compte des minuscule et des majuscule.
Ou si c'est lorsque j'utilise la fonction replace que tout passe en minuscule.
En traçant ce qui se passe à chaque étape on s'aperçoit que le problème survient dès l'appel de la fonction "GetDocumentNames", celle-ci est en amont de la fonction "Replace" qui n'a donc rien à voir avec le problème.
Option Explicit
Option Compare Text ' ne prend pas compte du fait des majuscule "XXXXX"="xxxxx"
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
Dim oFSO As Scripting.FileSystemObject
Dim oDrv As Drive
Dim oFl As Folder
Public Function DossierExiste(MonDossier As String)
If Len(Dir(MonDossier, vbDirectory)) > 0 Then
DossierExiste = True
Else
DossierExiste = False
End If
End Function
' ----------------------------------------------------création dossier---------------------------------------------------------------------------------
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("CopieDeProjet").Range("F2") = TextBox1.value
MonDossier = Sheets("CopieDeProjet").Range("F4")
If DossierExiste(MonDossier) = True Then
MsgBox "Le dossier existe... prendre un numero non utiliser"
Exit Sub
Else
MsgBox "dossier creer..."
MkDir Sheets("CopieDeProjet").Range("F4")
End If
'----------------------------------------------------enregistrement assemblage-----------------------------------------------------------------------------------------
Set swApp = CreateObject("SldWorks.application")
Set Part = swApp.ActiveDoc
boolstatus = Part.ForceRebuild3(True)
boolstatus = Part.Save2(False)
'longstatus = Part.SaveAs3(Sheets("CopieDeProjet").Range("F3") & "\" & Sheets("CopieDeProjet").Range("E2") & ".SLDASM", 0, 2)
'Set Part = Nothing
'swApp.CloseDoc Sheets("CopieDeProjet").Range("E2") & ".SLDASM"
'Set Part = swApp.OpenDoc6(Sheets("CopieDeProjet").Range("F3") & "\" & Sheets("CopieDeProjet").Range("E2") & ".SLDASM", 2, 0, "", longstatus, longwarnings)
'Set Part = swApp.ActiveDoc
'Part.ClearSelection2 True
'Part.EditRebuild3
Set swModelDoc = swApp.ActiveDoc
Set swModelDocExt = swModelDoc.Extension
Part.ClearSelection2 True
Part.EditRebuild3
'---------------------------------------------------------debut copie-----------------------------------------------------------------------------------------------------
Set swApp = CreateObject("SldWorks.Application")
' Get Pack and Go object
Set swPackAndGo = swModelDocExt.GetPackAndGo
' Get number of documents in assembly
namesCount = swPackAndGo.GetDocumentNamesCount
' 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 ""
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
End sub
Plus particullièrement la
' 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 ""
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
J'ai peut être trouvé une solution es que si je rajouterai un code de ce type a la fin de ma macro pour tout renommer en majuscule, penser vous que mes référence suivront dans sw ??
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ReDim pgGetFileNames(namesCount - 1)
ReDim pgDocumentStatus(namesCount - 1)
status = swPackAndGo.GetDocumentSaveToNames(pgGetFileNames, pgDocumentStatus)
' Pack and Go
statuses = swModelExt.SavePackAndGo(swPackAndGo)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Add the following lines after Pack and go command
For i = 0 To (namesCount - 1) '''''''''''''change lowecase to uppercase
Name pgGetFileNames(i) As UCase(pgGetFileNames(i)) ' Rename file.
If (Right(UCase(pgGetFileNames(i)), 7) = ".SLDPRT") Then
DRAW = Replace(UCase(pgGetFileNames(i)), "SLDPRT", "SLDDRW")
If Dir(DRAW) <> "" Then Name DRAW As UCase(DRAW)
End If
Next i
Cela ne règle pas le problème du mélange de minuscules et de majuscules comme dans ton exemple avec le mot "OrAngE", tu auras tout en majuscules au lieu de tout en minuscules.
Oui malheureusement je ne trouve aucune solution j 'ai donc rajoutée un bout de code qui passe par windows pour renommées mes pièces en majuscule il me reste qu'un souci c'est que mes pièces sont en majuscule.
mais quand j'ouvre Solidworks elle sont en minuscule
Ce n'est pas la casse que je voulais avoir mais je n'ai pas le choix a mon avis ... :/
Je ne vois pas pourquoi tu passes par Windows pour renommer tes pièces en majuscules, tu as juste à mettre :
For i = 0 To (namesCount - 1)
pgFileNames(i) = Replace(pgFileNames(i), pgFileNames(i), UCase(pgFileNames(i)))
Next i
Avant tes lignes :
myPath = " chemin du dossier "
status = swPackAndGo.SetSaveToName(True, myPath)
Et puis quand tu ouvres ton assemblage issu du PackAnGo vérifie bien que ton assemblage de départ soit fermé sinon Solidworks risque de se référencer à l'ancien assemblage plutôt qu'au nouveau car lui n'est pas sensible à la casse.
